geoip2 0.3.1.1 → 0.4.0.0

raw patch · 6 files changed

+156/−105 lines, 6 filesdep +lensPVP ok

version bump matches the API change (PVP)

Dependencies added: lens

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−0
• Data/GeoIP2.hs +111/−53
• Data/GeoIP2/Fields.hs +35/−48
• Data/GeoIP2/SearchTree.hs +1/−1
• README.md +2/−2
• geoip2.cabal +2/−1

@@ -1,3 +1,8 @@+# 0.4.0.0+- Added access to the complete parsed data+- Added dependency on lens, exported some prisms for easy access+- Small refactoring of functions, added more exports+ # 0.3.0.1 - Fix compiling with GHC 8.6.1 

@@ -2,6 +2,8 @@ {-# LANGUAGE MultiWayIf          #-} {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE RankNTypes #-}  module Data.GeoIP2 (   -- * Library description@@ -19,10 +21,20 @@   , openGeoDB, openGeoDBBS   , geoDbLanguages, geoDbType, geoDbDescription   , geoDbAddrType, GeoIP(..)+  , DecodeException(..)   -- * Querying the database   , findGeoData   , GeoResult(..)   , Location(..)+  , AS(..)+  -- * Internals+  , GeoField, GeoFieldT(..)+  , rawGeoData+  -- * Lenses +  , _DataString, _DataDouble, _DataInt, _DataWord+  , _DataMap, _DataArray, _DataBool, _DataUnknown+  , key+  , geoNum ) where  #if !MIN_VERSION_base(4,8,0)@@ -33,11 +45,12 @@ import qualified Data.ByteString        as BS import           Data.Int import           Data.IP                (IP (..), ipv4ToIPv6)-import qualified Data.Map               as Map-import           Data.Maybe             (fromMaybe, mapMaybe)+import           Data.Maybe             (mapMaybe) import           Data.Serialize import qualified Data.Text              as T import           System.IO.MMap+import           Control.Lens           (ix, (^?), _Just, to, (^..), Traversal', Fold, prism')+import           Control.Exception      (throwIO, Exception)  import           Data.GeoIP2.Fields import           Data.GeoIP2.SearchTree@@ -45,6 +58,10 @@ -- | Address type stored in database data GeoIP = GeoIPv6 | GeoIPv4 deriving (Eq, Show) +data DecodeException = DecodeException String+  deriving (Show)+instance Exception DecodeException+ -- | Handle for search operations data GeoDB = GeoDB {    geoMem           :: BS.ByteString@@ -65,66 +82,89 @@             (_, rest) -> lastsubstring pattern (BS.drop (BS.length pattern) rest)  -- | Open database, mmap it into memory, parse header and return a handle for search operations+-- This function may throw DecodeException openGeoDB :: FilePath -> IO GeoDB openGeoDB geoFile = do     bsmem <- mmapFileByteString geoFile Nothing-    parseGeoDB bsmem+    either (throwIO . DecodeException) return (openGeoDBBS bsmem) --- | Open database from a bytestring, parse header and return a handle for search operations-openGeoDBBS :: BS.ByteString -> IO GeoDB-openGeoDBBS  = parseGeoDB+-- | Open database from a bytestring+openGeoDBBS :: BS.ByteString -> Either String GeoDB+openGeoDBBS bsmem = do+    hdr <- decode (getHeaderBytes bsmem)+    when (hdr ^? key "binary_format_major_version" . geoNum /= (Just 2 :: Maybe Int)) $ +      Left "Unsupported database version, only v2 supported."+    unless (hdr ^? key "record_size" . geoNum `elem` (Just <$> [24, 28, 32 :: Int])) $+      Left "Record size not supported." -parseGeoDB :: BS.ByteString -> IO GeoDB-parseGeoDB bsmem = do-    DataMap hdr <- either error return $ decode (getHeaderBytes 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 bsmem (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")+    let res = GeoDB bsmem <$> hdr ^? key "database_type" . _DataString+                          <*> pure (hdr ^.. key "languages" . _DataArray . traverse . _DataString)+                          <*> hdr ^? key "node_count" . geoNum+                          <*> hdr ^? key "record_size" . geoNum+                          <*> hdr ^? key "ip_version" . toVersion+                          <*> pure (hdr ^? key "descritpion" . key "en" . _DataString)+    maybe (Left "Error decoding header") return res+  where+    toVersion = geoNum . prism' pfrom pto+      where+        pfrom :: GeoIP -> Int+        pfrom GeoIPv4 = 4+        pfrom GeoIPv6 = 6+        pto 4 = Just GeoIPv4+        pto 6 = Just GeoIPv6+        pto _ = Nothing +-- | Search GeoIP database and return complete unparsed data         rawGeoData :: GeoDB -> IP -> Either String GeoField rawGeoData geodb addr = do   bits <- coerceAddr-  offset <- fromIntegral <$> getDataOffset (geoMem geodb, geoDbNodeCount geodb, geoDbRecordSize geodb) bits-  basedata <- dataAt offset-  resolvePointers basedata+  offset <- getDataOffset (geoMem geodb, geoDbNodeCount geodb, geoDbRecordSize geodb) bits+  strictDataAt offset   where     dataSectionStart = (geoDbRecordSize geodb `div` 4) * fromIntegral (geoDbNodeCount geodb) + 16-    -- Add caching-    dataAt offset =  case decode (BS.drop (offset + dataSectionStart) (geoMem geodb)) of-                          Right res -> return res-                          Left err -> Left err+    dataSection = BS.drop dataSectionStart (geoMem geodb)+    +    strictDataAt :: Int64 -> Either String GeoField+    strictDataAt offset = do+      raw <- decode (BS.drop (fromIntegral offset) dataSection)+      traversePtr (strictDataAt . fromIntegral) raw+       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 = Left "Cannot search IPv6 address in IPv4 database"-    resolvePointers (DataPointer ptr) = dataAt (fromIntegral ptr) >>= resolvePointers -- TODO - limit recursion?-    resolvePointers (DataMap obj) = DataMap . Map.fromList <$> mapM resolveTuple (Map.toList obj)-    resolvePointers (DataArray arr) = DataArray <$> mapM resolvePointers arr-    resolvePointers x = return x-    resolveTuple (a,b) = (,) <$> resolvePointers a <*> resolvePointers b ++data AS = AS {+    asNumber       :: Int+  , asOrganization :: T.Text+} deriving (Show, Eq)+ -- | 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 Location-  , geoCity          :: Maybe T.Text-  , geoPostalCode    :: Maybe T.Text-  , geoSubdivisions  :: [(T.Text, T.Text)]+    geoContinent      :: Maybe T.Text+  , geoContinentCode  :: Maybe T.Text+  , geoCountryISO     :: Maybe T.Text+  , geoCountry        :: Maybe T.Text+  , geoLocation       :: Maybe Location+  , geoCity           :: Maybe T.Text+  , geoCityConfidence :: Maybe Int+  , geoPostalCode     :: Maybe T.Text+  , geoAS             :: Maybe AS+  , geoISP            :: Maybe T.Text+  , geoOrganization   :: Maybe T.Text+  , geoUserType       :: Maybe T.Text+  , geoSubdivisions   :: [(T.Text, T.Text)]+ } deriving (Show, Eq) +-- | Location of the IP address data Location = Location {     locationLatitude :: Double   , locationLongitude :: Double   , locationTimezone :: T.Text-  , locationAccuracy :: Int+  , locationAccuracy :: Maybe Int } deriving (Show, Eq)  -- | Search GeoIP database@@ -134,21 +174,39 @@   -> IP      -- ^ IP address to search   -> Either String GeoResult -- ^ Result, if something is found findGeoData geodb lang ip = do-  res <- rawGeoData geodb ip >>= asMap-  let subdivmap = res .:? "subdivisions" :: Maybe [Map.Map GeoField GeoField]-      subdivs = mapMaybe (\s -> (,) <$> s .:? "iso_code" <*> s .:? "names" ..? lang) <$> subdivmap+  res <- rawGeoData geodb ip+  let subdivmap = res ^.. key "subdivisions" . _DataArray . traverse+      subdivs = mapMaybe (\s -> (,) <$> s ^? key "iso_code"  . _DataString+                                    <*> s ^? key "names" . key lang . _DataString) subdivmap -  return $ GeoResult (res .:? "continent" ..? "names" ..? lang)-                     (res .:? "continent" ..? "code")-                     (res .:? "country" ..? "iso_code")-                     (res .:? "country" ..? "names" ..? lang)-                     (Location <$> res .:? "location" ..? "latitude"-                        <*> res .:? "location" ..? "longitude"-                        <*> res .:? "location" ..? "time_zone"-                        <*> res .:? "location" ..? "accuracy_radius")-                     (res .:? "city" ..? "names" ..? lang)-                     (res .:? "postal" ..? "code")-                     (fromMaybe [] subdivs)+  return $ GeoResult {+      geoContinent = res ^? key "continent" . key "names" . key lang . _DataString+    , geoContinentCode = res ^? key "continent" . key "code" . _DataString+    , geoCountryISO = res ^? key "country" . key "iso_code" . _DataString+    , geoCountry = res ^? key "country" . key "names" . key lang . _DataString+    , geoLocation = Location <$> res ^? key "location" . key "latitude" . _DataDouble+                            <*> res ^? key "location" . key "longitude" . _DataDouble+                            <*> res ^? key "location" . key "time_zone" . _DataString+                            <*> pure (res ^? key "location" . key "accuracy_radius" . geoNum)+    , geoCity = res ^? key "city" . key "names" . key lang . _DataString+    , geoCityConfidence = res ^? key "city" . key "confidence" . geoNum+    , geoPostalCode = res ^? key "postal" . key "code" . _DataString+    , geoAS = AS <$> res ^? key "traits" . key "autonomous_system_number" . geoNum+                 <*> res ^? key "traits" . key "autonomous_system_organization" . _DataString+    , geoISP = res ^? key "traits" . key "isp" . _DataString+    , geoOrganization = res ^? key "traits" . key "organization" . _DataString+    , geoUserType = res ^? key "traits" . key "user_type" . _DataString+    , geoSubdivisions = subdivs+  }++-- | Helper lens to access key in a DataMap+key :: T.Text -> Traversal' GeoField GeoField+key k = _DataMap . ix (DataString k)++-- | Helper lens to convert integer Word/Int to whatever number type is needed+geoNum :: Num b => Fold GeoField b+geoNum = to fromNum . _Just   where-    asMap (DataMap res) = return res-    asMap _             = Left "rawGeoData returned something else than DataMap"+    fromNum (DataInt x) = Just (fromIntegral x)+    fromNum (DataWord x) = Just (fromIntegral x)+    fromNum _ = Nothing

@@ -2,6 +2,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiWayIf        #-} {-# LANGUAGE CPP               #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE StandaloneDeriving     #-}  module Data.GeoIP2.Fields where @@ -15,67 +17,46 @@ import qualified Data.ByteString      as BS 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+import           Data.Void+import           Control.Lens.TH      (makePrisms) -data GeoField =-    DataPointer Int64+data GeoFieldT a =+    DataPointer a   | DataString !T.Text   | DataDouble Double   | DataInt Int64   | DataWord Word64-  | DataMap (Map.Map GeoField GeoField)-  | DataArray [GeoField]+  | DataMap (Map.Map (GeoFieldT a) (GeoFieldT a))+  | DataArray [GeoFieldT a]   | 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+  deriving (Eq, Ord)+-- Field with pointers resolved+type GeoField = GeoFieldT Void+deriving instance Show GeoField+-- Raw field with pointers+type GeoFieldRaw = GeoFieldT Int64 -(.:) :: GeoConvertable a => Map.Map GeoField GeoField  -> T.Text -> a-geo .: key = fromMaybe (error "Cannot find key.") (geo .:? key)+makePrisms ''GeoFieldT -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+-- | Go through the pointers and try to resolve them; we won't define instance of Applicative given that the 'key' to the Map is parametrized+traversePtr :: (Ord a, Applicative m) => (Int64 -> m (GeoFieldT a)) -> GeoFieldRaw -> m (GeoFieldT a)+traversePtr _ (DataString t) = pure (DataString t)+traversePtr _ (DataDouble t) = pure (DataDouble t)+traversePtr _ (DataInt t) = pure (DataInt t)+traversePtr _ (DataWord t) = pure (DataWord t)+traversePtr _ (DataBool t) = pure (DataBool t)+traversePtr _ (DataUnknown a b) = pure (DataUnknown a b)+-- For map we have to traverse over both keys and values...+traversePtr f (DataMap dmap) = DataMap . Map.fromList <$> traverse travBoth (Map.toList dmap)+  where+    travBoth (key, val) = (,) <$> traversePtr f key <*> traversePtr f val+traversePtr f (DataArray darr) = DataArray <$> traverse (traversePtr f) darr+traversePtr f (DataPointer a) = f a  -- | Parse number of given length parseNumber :: Num a => Int64 -> Get a@@ -84,6 +65,12 @@   return $ BS.foldl' (\acc new -> fromIntegral new + 256 * acc) 0 bytes  instance Serialize GeoField where+  put = error "Serialization not implemented"+  get = do+    field <- get+    traversePtr (\_ -> fail "Pointer not accepted at this position") field++instance Serialize GeoFieldRaw where   put = error "Serialization not implemented"   get = do     control <- getWord8

@@ -38,7 +38,7 @@     getnode _ index       | index == nodeCount = Left "Information for address does not exist."       | index > nodeCount = return $ index - nodeCount - 16-    getnode [] _ = Left "IP address too short????"+    getnode [] _ = Left "IP address too short"     getnode (bit:rest) index = getnode rest nextOffset       where         (left, right) = readNode mem recordSize index

@@ -19,8 +19,8 @@ main = do   geodb <- openGeoDB "GeoLite2-City.mmdb"   let ip = IPv4 "23.253.242.70"-  print $ (findGeoData geodb "en" ip)+  print (findGeoData geodb "en" ip)    let ip2 = IPv6 "2001:4800:7817:104:be76:4eff:fe04:f608"-  print $ (findGeoData geodb "en" ip2)+  print (findGeoData geodb "en" ip2) ```

@@ -1,5 +1,5 @@ name:                geoip2-version:             0.3.1.1+version:             0.4.0.0 synopsis:            Pure haskell interface to MaxMind GeoIP database description:   GeoIP2 is a haskell binding to the MaxMind GeoIP2 database.@@ -31,5 +31,6 @@                      , containers                      , iproute(>=1.4.0)                      , reinterpret-cast+                     , lens   default-language:    Haskell2010   ghc-options:         -Wall -fwarn-incomplete-uni-patterns