1 {-# LANGUAGE OverloadedStrings, TemplateHaskell, TypeFamilies #-} 2 module Databrary.Model.GeoNames 3 ( GeoName(..) 4 , geoNameUS 5 , parseGeoNameRef 6 , lookupGeoName 7 -- for testing 8 , parseGeoName 9 ) where 10 11 import Control.Monad (guard) 12 import qualified Data.ByteString.Char8 as BSC 13 import Data.Int (Int64) 14 import Data.List (stripPrefix) 15 import Data.Maybe (fromJust, fromMaybe, listToMaybe) 16 import qualified Data.Text as T 17 import qualified Network.HTTP.Client as HC 18 19 import qualified Databrary.JSON as JSON 20 import Databrary.HTTP.Client 21 import Databrary.Model.Id.Types 22 23 -- | Geonames use Int64 for their identifiers 24 type instance IdType GeoName = Int64 25 26 -- | values retrieved from geonames service. large db of place names including countries 27 data GeoName = GeoName 28 { geoNameId :: !(Id GeoName) -- ^ identifier from geonames service 29 , geoName :: !T.Text -- ^ human readable place name 30 } -- deriving (Eq, Show) 31 32 -- | hardcoded value for US geoname place 33 geoNameUS :: GeoName 34 geoNameUS = GeoName 35 { geoNameId = Id 6252001 36 , geoName = "United States" 37 } 38 39 -- | Extract geoname identifier from a geoname place url 40 parseGeoNameRef :: String -> Maybe (Id GeoName) 41 parseGeoNameRef s = listToMaybe $ do 42 (i, r) <- reads $ fromMaybe s (stripPrefix "http://sws.geonames.org/" s) 43 guard (null r || r == "/") 44 return $ Id i 45 46 -- | Parse the json response from a geoname id based place lookup into a GeoName value 47 parseGeoName :: JSON.Value -> JSON.Parser GeoName 48 parseGeoName = JSON.withObject "geoname" $ \j -> do 49 i <- j JSON..: "geonameId" 50 n <- j JSON..: "name" 51 return GeoName 52 { geoNameId = Id i 53 , geoName = n 54 } 55 56 -- | Build a request including URL, for performing a geonames API lookup 57 geoNameReq :: HC.Request 58 geoNameReq = (fromJust $ HC.parseRequest "http://api.geonames.org/getJSON") 59 { HC.cookieJar = Nothing } 60 61 -- | Perform a geoname Id based place lookup to get the corresponding place name, parsing the response into a GeoName value 62 lookupGeoName :: Id GeoName -> HTTPClient -> IO (Maybe GeoName) 63 lookupGeoName (Id i) hcm = do 64 j <- httpRequestJSON req hcm 65 return $ JSON.parseMaybe parseGeoName =<< j 66 where req = HC.setQueryString [("geonameId", Just $ BSC.pack $ show i), ("username", Just "databrary")] geoNameReq