geoip2 (empty) → 0.1.0.0
raw patch · 6 files changed
+360/−0 lines, 6 filesdep +basedep +binarydep +bytestringsetup-changed
Dependencies added: base, binary, bytestring, bytestring-mmap, containers, iproute, reinterpret-cast, text
Files
- Data/GeoIP2.hs +129/−0
- Data/GeoIP2/Fields.hs +122/−0
- Data/GeoIP2/SearchTree.hs +48/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- geoip2.cabal +29/−0
+ Data/GeoIP2.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiWayIf #-}++module Data.GeoIP2 (+ -- * Library description+ -- |+ -- A haskell library for reading MaxMind's GeoIP version 2 files.+ -- It supports both IPv4 and IPv6 addresses. When a match is found, it+ -- is parsed and a simplified structure is returned. If you want to access+ -- other fields than those that are exposed, it is internally possible.+ --+ -- The database is mmapped upon opening, all querying can be later+ -- performed purely without IO monad.++ -- * Opening the database+ GeoDB+ , openGeoDB+ , geoDbLanguages, geoDbType, geoDbDescription, geoDbAddrType+ -- * Querying the database+ , findGeoData+ , GeoResult(..)+) where++import Control.Monad (when, unless)+import System.IO.Posix.MMap+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import Data.Int+import Data.Binary+import qualified Data.Text as T+import Data.IP (IP(..), ipv4ToIPv6)+import Control.Applicative ((<$>), (<*>))+import qualified Data.Map as Map+import Data.Maybe (mapMaybe, fromMaybe)++import Data.GeoIP2.Fields+import Data.GeoIP2.SearchTree++-- | Address type stored in database+data GeoIP = GeoIPv6 | GeoIPv4 deriving (Eq, Show)++-- | Handle for search operations+data GeoDB = GeoDB {+ geoMem :: BL.ByteString+ , geoDbType :: T.Text -- ^ String that indicates the structure of each data record associated with an IP address+ , geoDbLanguages :: [T.Text] -- ^ Languages supported in database+ , geoDbNodeCount :: Int64+ , geoDbRecordSize :: Int+ , geoDbAddrType :: GeoIP -- ^ Type of address (IPv4/IPv6) stored in a database+ , geoDbDescription :: Maybe T.Text -- ^ Description of a database in english+}++getHeaderBytes :: BS.ByteString -> BS.ByteString+getHeaderBytes = lastsubstring "\xab\xcd\xefMaxMind.com"+ where+ lastsubstring pattern string =+ case BS.breakSubstring pattern string of+ (res, "") -> res+ (_, rest) -> lastsubstring pattern (BS.drop (BS.length pattern) rest)++-- | Open database, mmap it into memory, parse header and return a handle for search operations+openGeoDB :: FilePath -> IO GeoDB+openGeoDB geoFile = do+ bsmem <- unsafeMMapFile geoFile+ let (DataMap hdr) = decode (BL.fromChunks [getHeaderBytes bsmem])+ mem = BL.fromChunks [bsmem]+ when (hdr .: "binary_format_major_version" /= (2 :: Int)) $ error "Unsupported database version, only v2 supported."+ unless (hdr .: "record_size" `elem` [24, 28, 32 :: Int]) $ error "Record size not supported."+ return $ GeoDB mem (hdr .: "database_type")+ (fromMaybe [] $ hdr .:? "languages")+ (hdr .: "node_count") (hdr .: "record_size")+ (if (hdr .: "ip_version") == (4 :: Int) then GeoIPv4 else GeoIPv6)+ (hdr .:? "description" ..? "en")++++rawGeoData :: Monad m => GeoDB -> IP -> m GeoField+rawGeoData geodb addr = do+ bits <- coerceAddr+ offset <- getDataOffset (geoMem geodb, geoDbNodeCount geodb, geoDbRecordSize geodb) bits+ let basedata = dataAt offset+ return $ resolvePointers basedata+ where+ dataSectionStart = fromIntegral (geoDbRecordSize geodb `div` 4) * geoDbNodeCount geodb + 16+ dataAt offset = decode (BL.drop (offset + dataSectionStart) (geoMem geodb))+ coerceAddr+ | (IPv4 _) <- addr, GeoIPv4 <- geoDbAddrType geodb = return $ ipToBits addr+ | (IPv6 _) <- addr, GeoIPv6 <- geoDbAddrType geodb = return $ ipToBits addr+ | (IPv4 addrv4) <- addr, GeoIPv6 <- geoDbAddrType geodb = return $ ipToBits $ IPv6 (ipv4ToIPv6 addrv4)+ | otherwise = fail "Cannot search IPv6 address in IPv4 database"+ resolvePointers (DataPointer ptr) = resolvePointers $ dataAt ptr+ resolvePointers (DataMap obj) = DataMap $ Map.fromList $ map resolveTuple (Map.toList obj)+ resolvePointers (DataArray arr) = DataArray $ map resolvePointers arr+ resolvePointers x = x+ resolveTuple (a,b) =+ let r1 = resolvePointers a+ r2 = resolvePointers b+ in (r1, r2)++-- | Result of a search query+data GeoResult = GeoResult {+ geoContinent :: Maybe T.Text+ , geoContinentCode :: Maybe T.Text+ , geoCountryISO :: Maybe T.Text+ , geoCountry :: Maybe T.Text+ , geoLocation :: Maybe (Double, Double)+ , geoCity :: Maybe T.Text+ , geoSubdivisions :: [(T.Text, T.Text)]+} deriving (Show, Eq)++-- | Search GeoIP database, monadic version (e.g. use with Maybe or Either)+findGeoData :: Monad m =>+ GeoDB -- ^ Db handle+ -> T.Text -- ^ Language code (e.g. "en")+ -> IP -- ^ IP address to search+ -> m GeoResult -- ^ Result, if something is found+findGeoData geodb lang ip = do+ (DataMap res) <- rawGeoData geodb ip+ let subdivmap = res .:? "subdivisions" :: Maybe [Map.Map GeoField GeoField]+ subdivs = mapMaybe (\s -> (,) <$> s .:? "iso_code" <*> s .:? "names" ..? lang) <$> subdivmap++ return $ GeoResult (res .:? "continent" ..? "names" ..? lang)+ (res .:? "continent" ..? "code")+ (res .:? "country" ..? "iso_code")+ (res .:? "country" ..? "names" ..? lang)+ ((,) <$> res .:? "location" ..? "latitude" <*> res .:? "location" ..? "longitude")+ (res .:? "city" ..? "names" ..? lang)+ (fromMaybe [] subdivs)
+ Data/GeoIP2/Fields.hs view
@@ -0,0 +1,122 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE FlexibleInstances #-}++module Data.GeoIP2.Fields where++import Control.Applicative ((<$>))+import Control.Monad (replicateM, replicateM_)+import Data.Binary+import Data.Binary.Get+import Data.Bits (shift, (.&.))+import Data.Int+import qualified Data.Map as Map+import Data.Maybe (fromMaybe)+import Data.ReinterpretCast (wordToDouble)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8)+import Data.Word ()++data GeoField =+ DataPointer Int64+ | DataString T.Text+ | DataDouble Double+ | DataInt Int64+ | DataWord Word64+ | DataMap (Map.Map GeoField GeoField)+ | DataArray [GeoField]+ | DataBool Bool+ | DataUnknown Word8 Int64+ deriving (Eq, Ord, Show)++class GeoConvertable a where+ cvtGeo :: GeoField -> Maybe a++(..?) :: GeoConvertable a => Maybe (Map.Map GeoField GeoField) -> T.Text -> Maybe a+(Just geo) ..? name = Map.lookup (DataString name) geo >>= cvtGeo+_ ..? _ = Nothing++(.:?) :: GeoConvertable a => Map.Map GeoField GeoField -> T.Text -> Maybe a+geo .:? name = Map.lookup (DataString name) geo >>= cvtGeo++(.:) :: GeoConvertable a => Map.Map GeoField GeoField -> T.Text -> a+geo .: key = fromMaybe (error "Cannot find key.") (geo .:? key)++instance GeoConvertable (Map.Map GeoField GeoField) where+ cvtGeo (DataMap obj) = Just obj+ cvtGeo _ = Nothing+instance GeoConvertable [GeoField] where+ cvtGeo (DataArray arr) = Just arr+ cvtGeo _ = Nothing+instance GeoConvertable T.Text where+ cvtGeo (DataString txt) = Just txt+ cvtGeo _ = Nothing+instance GeoConvertable Double where+ cvtGeo (DataDouble d) = Just d+ cvtGeo _ = Nothing+instance GeoConvertable Int where+ cvtGeo (DataInt i) = Just $ fromIntegral i+ cvtGeo (DataWord w) = Just $ fromIntegral w+ cvtGeo _ = Nothing+instance GeoConvertable Int64 where+ cvtGeo (DataInt i) = Just $ fromIntegral i+ cvtGeo (DataWord w) = Just $ fromIntegral w+ cvtGeo _ = Nothing+instance GeoConvertable Word where+ cvtGeo (DataInt i) = Just $ fromIntegral i+ cvtGeo (DataWord w) = Just $ fromIntegral w+ cvtGeo _ = Nothing+instance GeoConvertable a => GeoConvertable [a] where+ cvtGeo (DataArray arr) = mapM cvtGeo arr+ cvtGeo _ = Nothing+instance GeoConvertable Bool where+ cvtGeo (DataBool b) = Just b+ cvtGeo _ = Nothing++-- | Parse number of given length+parseNumber :: Num a => Int64 -> Get a+parseNumber fsize = do+ bytes <- map fromIntegral <$> replicateM (fromIntegral fsize) getWord8+ return $ foldl (\acc new -> new + 256 * acc) 0 bytes++instance Binary GeoField where+ put = undefined+ get = do+ control <- getWord8+ ftype <- if | control .&. 0xe0 == 0 -> (+7) <$> getWord8+ | otherwise -> return $ control `shift` (-5)+ let _fsize = fromIntegral $ control .&. 0x1f :: Int64+ fsize <- if+ | ftype == 1 -> do+ let _ss = _fsize `shift` (-3)+ _vval = fromIntegral $ _fsize .&. 0x7+ case _ss of+ 0 -> ((_vval `shift` 8) +) <$> parseNumber 1+ 1 -> ((2048 + (_vval `shift` 16)) +) <$> parseNumber 2+ 2 -> ((526336 + (_vval `shift` 24)) +) <$> parseNumber 3+ 3 -> parseNumber 4+ _ -> error "Cannot happen"+ | _fsize < 29 -> return _fsize+ | _fsize == 29 -> (29+) <$> parseNumber 1+ | _fsize == 30 -> (285+) <$> parseNumber 2+ | _fsize == 31 -> (65821+) <$> parseNumber 3++ case ftype of+ 1 -> return $ DataPointer fsize+ 2 -> DataString . decodeUtf8 <$> getByteString (fromIntegral fsize)+ 3 -> DataDouble . wordToDouble <$> get+ 5 -> DataWord <$> parseNumber fsize+ 6 -> DataWord <$> parseNumber fsize+ 7 -> do+ pairs <- replicateM (fromIntegral fsize) $ do+ key <- get+ val <- get+ return (key, val)+ return $ DataMap (Map.fromList pairs)+ 8 -> DataWord <$> parseNumber fsize+ 9 -> DataWord <$> parseNumber fsize+ 11 -> DataArray <$> replicateM (fromIntegral fsize) get+ 14 -> return $ DataBool (fsize == 0)+ _ -> do+ replicateM_ (fromIntegral fsize) getWord8+ return $ DataUnknown ftype fsize
+ Data/GeoIP2/SearchTree.hs view
@@ -0,0 +1,48 @@+{-# OPTIONS_HADDOCK hide #-}++module Data.GeoIP2.SearchTree where++import Data.Binary+import Data.Bits (shift, testBit, (.&.), (.|.))+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import Data.Int+import Data.IP (IP (..), fromIPv4, fromIPv6b)++-- | Convert byte to list of bits starting from the most significant one+byteToBits :: Int -> [Bool]+byteToBits b = map (testBit b) [7,6..0]++-- | Convert IP address to bits+ipToBits :: IP -> [Bool]+ipToBits (IPv4 addr) = concatMap byteToBits (fromIPv4 addr)+ipToBits (IPv6 addr) = concatMap byteToBits (fromIPv6b addr)++-- | Read node (2 records) given the index of a node+readNode :: BL.ByteString -> Int -> Int64 -> (Int64, Int64)+readNode mem recordbits index =+ let+ bytecount = fromIntegral $ recordbits `div` 4+ bytes = BL.take (fromIntegral bytecount) $ BL.drop (fromIntegral $ index * bytecount) mem+ numbers = concatMap BS.unpack (BL.toChunks bytes) :: [Word8]+ makenum = foldl (\acc new -> fromIntegral new + 256 * acc) 0 :: [Word8] -> Word64+ num = makenum numbers+ -- 28 bits has a strange record format+ left28 = num `shift` (-32) .|. (num .&. 0xf0000000)+ in case recordbits of+ 28 -> (fromIntegral left28, fromIntegral (num .&. ((1 `shift` recordbits) - 1)))+ _ -> (fromIntegral (num `shift` negate recordbits), fromIntegral (num .&. ((1 `shift` recordbits) - 1)))++-- | Get offset in the Data Section+getDataOffset :: Monad m => (BL.ByteString, Int64, Int) -> [Bool] -> m Int64+getDataOffset (mem, nodeCount, recordSize) startbits =+ getnode startbits 0+ where+ getnode _ index+ | index == nodeCount = fail "Information for address does not exist."+ | index > nodeCount = return $ index - nodeCount - 16+ getnode [] _ = fail "IP address too short????"+ getnode (bit:rest) index = getnode rest nextOffset+ where+ (left, right) = readNode mem recordSize index+ nextOffset = if bit then right else left
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Ondrej Palkovsky++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Ondrej Palkovsky nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ geoip2.cabal view
@@ -0,0 +1,29 @@+name: geoip2+version: 0.1.0.0+synopsis: Pure haskell interface to MaxMind GeoIP database+description:+ GeoIP2 is a haskell binding to the MaxMind GeoIP2 database.+ It parses the database according to the MaxMind DB+ specification <http://maxmind.github.io/MaxMind-DB/>, version 2+ of the specification is supported. The free geolite2 database can+ be downloaded at <http://dev.maxmind.com/geoip/geoip2/geolite2/>.+license: BSD3+license-file: LICENSE+author: Ondrej Palkovsky+maintainer: palkovsky.ondrej@gmail.com+category: Database+build-type: Simple+cabal-version: >=1.10++source-repository head+ type: git+ location: https://github.com/ondrap/geoip2++library+ exposed-modules: Data.GeoIP2+ other-modules: Data.GeoIP2.Fields, Data.GeoIP2.SearchTree+ build-depends: base >=4.7 && <4.8,+ bytestring-mmap, bytestring, binary, text, containers,+ iproute(>=1.4.0), reinterpret-cast+ default-language: Haskell2010+ ghc-options: -Wall