diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Mike Pilgrem (c) 2017 + +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 Mike Pilgrem 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/google-maps-geocoding.cabal b/google-maps-geocoding.cabal new file mode 100644 --- /dev/null +++ b/google-maps-geocoding.cabal @@ -0,0 +1,31 @@ +name: google-maps-geocoding +version: 0.1.0.0 +synopsis: Google Maps Geocoding API bindings +description: The Google Maps Geocoding API provides a direct way to + access geocoding and reverse geocoding services via an HTTP + request. +homepage: https://github.com/mpilgrem/google-maps-geocoding#readme +bug-reports: https://github.com/mpilgrem/google-maps-geocoding/issues +license: BSD3 +license-file: LICENSE +author: Mike Pilgrem +maintainer: public@pilgrem.com +copyright: Mike Pilgrem +category: Web +build-type: Simple +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Web.Google.Maps.Geocoding + build-depends: base >= 4.7 && < 5 + , aeson >= 1.0 && < 1.1 + , http-client >= 0.5 && < 0.6 + , servant >= 0.9 && < 0.10 + , servant-client >= 0.9 && <0.10 + , text >= 1.2 && < 1.3 + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/mpilgrem/google-maps-geocoding.git diff --git a/src/Web/Google/Maps/Geocoding.hs b/src/Web/Google/Maps/Geocoding.hs new file mode 100644 --- /dev/null +++ b/src/Web/Google/Maps/Geocoding.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : Web.Google.Maps.Geocoding +-- Description : Bindings to the Google Maps Geocoding API +-- Copyright : (c) Mike Pilgrem 2017 +-- Maintainer : public@pilgrem.com +-- Stability : experimental +-- +-- The +-- provides a direct way to access geocoding and reverse geocoding services via +-- an HTTP request. +-- +-- The 'components' and optional parameters in a geocoding request are not yet +-- implemented. The reverse geocoding request is not yet implemented. +-- +-- Below is an example of use. +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > module Main (main) where +-- > +-- > import Data.Text (Text) +-- > import Data.Text.IO as T (getLine, putStr) +-- > import Network.HTTP.Client (newManager) +-- > import Network.HTTP.Client.TLS (tlsManagerSettings) +-- > import Web.Google.Maps.Geocoding (Address (..), geocode, GeocodingResponse (..), +-- > Geometry (..), Key (..), Location (..), Result (..), Status (..)) +-- > import System.IO (hFlush, stdout) +-- > +-- > main :: IO () +-- > main = do +-- > txt <- input "Enter full address: " +-- > mgr <- newManager tlsManagerSettings +-- > let apiKey = Key "" +-- > result <- geocode mgr apiKey (Address txt) +-- > case result of +-- > Right response -> do +-- > let s = status response +-- > case s of +-- > OK -> print $ location $ geometry $ head $ results response +-- > _ -> putStrLn $ "Error! Status: " ++ show s +-- > _ -> putStrLn $ "Error! Result:\n" ++ show result +-- > +-- > input :: Text -> IO Text +-- > input msg = T.putStr msg >> hFlush stdout >> T.getLine +module Web.Google.Maps.Geocoding + ( -- * Functions + geocode + -- * API + , GoogleMapsGeocodingAPI + , api + -- * Types + , Key (..) + , Address (..) + , GeocodingResponse (..) + , Status (..) + , Result (..) + , AddressType (..) + , AddressComponent (..) + , PostcodeLocality (..) + , Geometry (..) + , PlaceId (..) + , Location (..) + , LocationType (..) + , Viewport (..) + ) where + +import Data.Aeson hiding (Result) +import Data.Aeson.Types (Options (..)) +import Data.Foldable (asum) +import Data.Proxy +import Data.Text (Text) +import qualified Data.Text as T (unpack) +import GHC.Generics +import Network.HTTP.Client (Manager) +import Servant.API +import Servant.Client + +-- | API key +newtype Key = Key Text + deriving (Eq, Show, ToHttpApiData) + +-- | Address +newtype Address = Address Text + deriving (Eq, Show, ToHttpApiData) + +-- | Geocoding Reponse +data GeocodingResponse = GeocodingResponse + { status :: Status + , error_message :: Maybe Text + , results :: [Result] + } deriving (Eq, Show, Generic) + +instance FromJSON GeocodingResponse + +-- | Contains the status of the request and may contain debugging information to +-- help you track down why geocoding is not working. +data Status + = OK -- ^ Indicates that no errors occurred; the address was + -- successfully parsed and at least one geocode was + -- returned. + | ZeroResults -- ^ Indicates that the geocode was successful but + -- returned no results. This may occur if the geocoder was + -- passed a non-existent address. + | OverQueryLimit + | RequestDenied + | InvalidRequest -- ^ Generally indicates that the query (address, + -- components or latlng) is missing. + | UnknownError + deriving (Eq, Show) + +instance FromJSON Status where + parseJSON = withText "Status" $ \t -> case t of + "OK" -> return OK + "ZERO_RESULTS" -> return ZeroResults + "OVER_QUERY_LIMIT" -> return OverQueryLimit + "REQUEST_DENIED" -> return RequestDenied + "INVALID_REQUEST" -> return InvalidRequest + "UNKNOWN_ERROR" -> return UnknownError + _ -> fail $ "Unrecognised status type, namely: " ++ + T.unpack t + +-- | A result of the geocoder. +data Result = Result + { types :: [AddressType] + , formatted_address :: Text + , address_components :: [AddressComponent] + , postcode_localities :: Maybe [PostcodeLocality] + , geometry :: Geometry + , partial_match :: Maybe Bool + , place_id :: PlaceId + } deriving (Eq, Show, Generic) + +instance FromJSON Result + +-- | Address (and address component) type: The list of types provided by Google +-- (as at 4 March 2017) is incomplete. +data AddressType = AddressType Text + deriving (Eq, Show, Generic) + +instance FromJSON AddressType + +-- | Address component +data AddressComponent = AddressComponent + { address_component_types :: [AddressType] + , long_name :: Text + , short_name :: Text + } deriving (Eq, Show, Generic) + +instance FromJSON AddressComponent where + parseJSON = genericParseJSON defaultOptions + { fieldLabelModifier = \l -> case l of + "address_component_types" -> "types" + _ -> l + } + +-- | Postcode locality: a locality contained in a postal code +newtype PostcodeLocality = PostcodeLocality Text + deriving (Eq, Show, Generic) + +instance FromJSON PostcodeLocality + +-- | Geometry +data Geometry = Geometry + { location :: Location + , location_type :: LocationType + , viewport :: Viewport + , bounds :: Maybe Viewport + } deriving (Eq, Show, Generic) + +instance FromJSON Geometry + +-- | Location +data Location = Location + { lat :: Double + , lng :: Double + } deriving (Eq, Show, Generic) + +instance FromJSON Location + +-- | Location type +data LocationType + = Rooftop + | RangeInterpolated + | GeometricCenter + | Approximate + deriving (Eq, Show) + +instance FromJSON LocationType where + parseJSON = withText "LocationType" $ \t -> case t of + "ROOFTOP" -> return Rooftop + "RANGE_INTERPOLATED" -> return RangeInterpolated + "GEOMETRIC_CENTER" -> return GeometricCenter + "APPROXIMATE" -> return Approximate + _ -> fail $ "Unrecognised location type, namely: " ++ T.unpack t + +-- | Viewport +data Viewport = Viewport + { southwest :: Location + , northeast :: Location + } deriving (Eq, Show, Generic) + +instance FromJSON Viewport + +-- | Place id +newtype PlaceId = PlaceId Text + deriving (Eq, Show, Generic) + +instance FromJSON PlaceId + +-- | Google Translate API +type GoogleMapsGeocodingAPI + = "json" + :> QueryParam "key" Key + :> QueryParam "address" Address + :> Get '[JSON] GeocodingResponse + +-- | API type +api :: Proxy GoogleMapsGeocodingAPI +api = Proxy + +geocode' + :: Maybe Key + -> Maybe Address + -> ClientM GeocodingResponse +geocode' = client api + +googleApis :: BaseUrl +googleApis = BaseUrl Https "maps.googleapis.com" 443 "/maps/api/geocode" + +-- | Geocode +geocode + :: Manager + -> Key + -> Address + -> IO (Either ServantError GeocodingResponse) +geocode mgr key address = + runClientM (geocode' (Just key) (Just address)) (ClientEnv mgr googleApis)