diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/Data/GeoIP2.hs b/Data/GeoIP2.hs --- a/Data/GeoIP2.hs +++ b/Data/GeoIP2.hs @@ -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 diff --git a/Data/GeoIP2/Fields.hs b/Data/GeoIP2/Fields.hs --- a/Data/GeoIP2/Fields.hs +++ b/Data/GeoIP2/Fields.hs @@ -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 diff --git a/Data/GeoIP2/SearchTree.hs b/Data/GeoIP2/SearchTree.hs --- a/Data/GeoIP2/SearchTree.hs +++ b/Data/GeoIP2/SearchTree.hs @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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) ``` diff --git a/geoip2.cabal b/geoip2.cabal --- a/geoip2.cabal +++ b/geoip2.cabal @@ -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