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