diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2015 Jan Greve, Markenwerk GmbH + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. 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/geo-resolver.cabal b/geo-resolver.cabal new file mode 100644 --- /dev/null +++ b/geo-resolver.cabal @@ -0,0 +1,47 @@ +name: geo-resolver +version: 0.1.0.1 +synopsis: Performs geo location lookups and parses the results +description: Please see README.md +homepage: https://github.com/markenwerk/haskell-geo-resolver/ +license: MIT +license-file: LICENSE +author: Jan Greve +maintainer: jg@markenwerk.net +copyright: 2015 Jan Greve, Markenwerk GmbH +category: Web +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Network.Google.GeoResolver, Network.Google.GeoResolver.Parser, Network.Google.GeoResolver.Requester + build-depends: base >= 4.7 && < 5, + aeson >= 0.8.0.2 && < 1, + http-conduit >= 2.1.8 && < 2.2, + bytestring, + unordered-containers, + text, + http-types, + blaze-builder + default-language: Haskell2010 + +test-suite GeoResolver-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base, + test-framework, + test-framework-hunit, + geo-resolver, + bytestring, + HUnit, + QuickCheck, + test-framework-quickcheck2, + base64-bytestring >= 1 && < 1.1 + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/markenwerk/haskell-geo-resolver.git diff --git a/src/Network/Google/GeoResolver.hs b/src/Network/Google/GeoResolver.hs new file mode 100644 --- /dev/null +++ b/src/Network/Google/GeoResolver.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : GeoResolver +Description : Simple way to access Google's geocoding API. Using http-conduit. +Copyright : (c) 2015, Markenwerk, Jan Greve +License : MIT +Maintainer : jg@markenwerk.net + + +This is supposed to offer an easy to use abstraction of the google geocoding +web service. + +A minimum example of usage (with @OverloadedStrings@) is: + +@ +import GeoRequester +main = geoRequest "Lornsenstraße 43, Kiel" >>= putStrLn . show +@ + +While there are convenience functions for the most common use cases, +there are means to send arbitrary requests. + +If you do so, please see "Geocoder.Parser" for ways to access the results. +As a hint, 'GoogleAnswer' is instance of 'Foldable' and 'Functor'. + + +Please note that this Package is also meant to demonstrate basic Haskell features +and thus not always takes the most elegant way but the most educational way. + +-} + +module Network.Google.GeoResolver + ( + -- * Encoding + geoEncode, + geoEncodeLanguage, + -- * Decoding + geoDecode, + geoDecodeLanguage, + -- * Raw Requesting + geoRequest, + geoRaw + ) where +import Network.Google.GeoResolver.Requester +import Network.Google.GeoResolver.Parser +import Control.Monad +import Data.Text (pack, append) + + +-- | Encodes a given address into a coordinate. +geoEncode :: Maybe String -- ^ Optional API key to use if you intend to go over the courtesy limit + -- Google imposes + -> String -- ^ The address to be looked up. + -> IO (Either String (Double, Double)) -- ^ Either an error message or the result. +geoEncode mk x = + liftM (parseAnswer >=> getLocation) (requestEncode (fmap pack mk) (pack x)) + +-- | Encodes a given address into a coordinate. +geoEncodeLanguage :: Maybe String -- ^ Optional API key to use if you intend to go over the courtesy limit + -- Google imposes + -> String -- ^ The address to be looked up. + -> String -- ^ Language to be used. cf. https://developers.google.com/maps/faq#languagesupport + -> IO (Either String (Double, Double)) -- ^ Either an error message or the result. +geoEncodeLanguage Nothing addr lang = + liftM (parseAnswer >=> getLocation) + (requestRaw [("address", pack addr), ("language", pack lang)]) + +geoEncodeLanguage (Just k) addr lang = + liftM (parseAnswer >=> getLocation) + (requestRaw [("address", pack addr), ("language", pack lang), ("key", pack k)]) + +-- | Reverse geocoding of a given coordinate pair into an address. +geoDecode :: Maybe String -- ^ Optional API key to use if you intend to go over the courtesy limit + -- Google imposes + -> (Double, Double) -- ^ coordinate to be decoded + -> IO (Either String String) -- ^ Either an error message (Left) or the result (Right). +geoDecode mk x = + liftM (parseAnswer >=> getAddress) + (requestDecode (fmap pack mk) x) + +-- | Reverse geocoding of a given coordinate pair into an address. +geoDecodeLanguage :: Maybe String -- ^ Optional API key to use if you intend to go over the courtesy limit + -- Google imposes + -> (Double, Double) -- ^ coordinate to be decoded + -> String -- ^ Language to be used. cf. https://developers.google.com/maps/faq#languagesupport + -> IO (Either String String) -- ^ Either an error message (Left) or the result (Right). +geoDecodeLanguage Nothing (lat, lng) lang = + liftM (parseAnswer >=> getAddress) + (requestRaw + [("latlng",pack (show lat) `append` pack (',' : show lng)), ("language", pack lang)]) +geoDecodeLanguage (Just k) (lat, lng) lang = + liftM (parseAnswer >=> getAddress) + (requestRaw + [("latlng",pack (show lat) `append` pack (',' : show lng)), ("language", pack lang), ("key", pack k)]) + +-- | Sends a request based on a 'GoogleRequest'. +geoRequest :: GoogleRequest -> IO (Either String (GoogleAnswer GoogleResult)) +geoRequest r = liftM parseAnswer (requestRequest r) + + +-- | Sending a raw request to the api, if you want more control than the above methods offer. +-- Uses a pair of key-value pairs to generate the actual query. +-- See "GeoResolver.Parser" for a helping hand using the resulting 'GoogleAnswer'. +geoRaw :: [(String, String)] -> IO (Either String (GoogleAnswer GoogleResult)) +geoRaw xs = liftM parseAnswer (requestRaw (map (\(k,v) -> (pack k, pack v)) xs)) diff --git a/src/Network/Google/GeoResolver/Parser.hs b/src/Network/Google/GeoResolver/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Network/Google/GeoResolver/Parser.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE OverloadedStrings, DeriveGeneric #-} +{-| +Module : GeoResolver.Parser +Description : Parsing helper definitions for Googles geocoding API. +Copyright : (c) 2015, Markenwerk, Jan Greve +License : MIT +Maintainer : jg@markenwerk.net +-} +module Network.Google.GeoResolver.Parser ( + -- * Data type definition for parsed types + Status(..), + GoogleAnswer(..), + GoogleResult(..), + Component(..), + Geometry(..), + GoogleBoundingBox(..), + Location(..), + -- * parsing + parseAnswer, + -- * convenience functions + getLocation, + getAddress, + getProperty, + -- * Typeclasses + GoogleArgumentListShow(..) + ) where + +import GHC.Generics +import Data.Aeson +import Data.HashMap.Strict +import Data.Text +import Data.Maybe (fromMaybe) +import Control.Arrow +import qualified Data.ByteString.Lazy.Char8 as LBS + + +-- | A class to format instances the way google expects them. +class GoogleArgumentListShow a where + argListShow :: a -> String + + +-- | Represents the status of the operation returned by google. Constructors represent possible 'String' values +-- according to googles documentation. +data Status = OK | ZERO_RESULTS | OVER_QUERY_LIMIT | REQUEST_DENIED | INVALID_REQUEST | UNKNOWN_ERROR + deriving (Eq, Show, Generic) +instance FromJSON Status + +-- | Represents the answer google returned. +data GoogleAnswer r = GoogleAnswer { + -- | The 'Status' returned by google. + status :: Status, + -- | An optional error message. + errorMessage :: Maybe String, + -- | Optional list of actual 'GoogleResult' values. + results :: Maybe [r] + } deriving (Show, Eq) +instance (FromJSON a) => FromJSON (GoogleAnswer a) where + parseJSON (Object v) = GoogleAnswer <$> + v .: "status" <*> + v .:? "error_message" <*> + v .:? "results" + parseJSON _ = mempty + +instance Functor GoogleAnswer where + fmap f (GoogleAnswer s e Nothing) = (GoogleAnswer s e Nothing) + fmap f (GoogleAnswer s e (Just xs)) = (GoogleAnswer s e (Just $ fmap f xs)) + +instance Foldable GoogleAnswer where + foldMap _ (GoogleAnswer _ _ Nothing) = mempty + foldMap f (GoogleAnswer _ _ (Just [r])) = f r + foldMap f (GoogleAnswer _ _ (Just rs)) = foldMap f rs + + +-- | A single Result from the list of results from google. +data GoogleResult = GoogleResult { + -- | List of 'Component' values for this result + addressComponents :: [Component], + -- | The formatted address google returned + formattedAddress :: String, + -- | The 'Geometry' value for this result + geometry :: Geometry, + -- | The google places ID for this result + placeId :: String, + -- | Some list of strings. Goole says: + -- + -- The types[] array indicates the type of the returned result. + -- This array contains a set of zero or more tags identifying the type of feature returned in the result. + -- For example, a geocode of "Chicago" returns "locality" which indicates that "Chicago" is a city, + -- and also returns "political" which indicates it is a political entity. + types :: [String], + -- | If present, hinting that this result only partially matches the requested entity. + partialMatch :: Maybe Bool + } deriving (Show, Generic) +instance FromJSON GoogleResult where + parseJSON (Object v) = GoogleResult <$> + v .: "address_components" <*> + v .: "formatted_address" <*> + v .: "geometry" <*> + v .: "place_id" <*> + v .: "types" <*> + v .:? "partial_match" + parseJSON _ = mempty + +-- | A part of the address in a 'GoogleResult' +data Component = Component { + -- | A long name for the component + longName :: String, + -- | A short name for the component + shortName :: String, + -- | indicating the type of the address component. + cTypes :: [String] + } deriving (Show, Eq) +instance FromJSON Component where + parseJSON (Object v) = Component <$> + v .: "long_name" <*> + v .: "short_name" <*> + v .: "types" + parseJSON _ = mempty + + +-- | Holds geometry information about a 'GoogleResult' +data Geometry = Geometry { + -- | The result's location + location :: Location, + -- | The kind of location. As of 2015/10/07, the + -- following values are to be expected. For future compatibility, + -- no Enum type is introduced to map this. + -- + -- * @ROOFTOP@ indicates that the returned result is a precise geocode for + -- which we have location information accurate down to street address precision. + -- + -- * @RANGE_INTERPOLATED@ indicates that the returned result reflects + -- an approximation (usually on a road) interpolated between two precise points + -- (such as intersections). Interpolated results are generally returned + -- when rooftop geocodes are unavailable for a street address. + -- + -- * @GEOMETRIC_CENTER@ indicates that the returned result is the geometric + -- center of a result such as a polyline (for example, a street) or + -- polygon (region). + -- + -- * @APPROXIMATE@ indicates that the returned result is approximate. + locationType :: String, + -- | contains the recommended viewport for displaying the returned result. + -- Generally the viewport + -- is used to frame a result when displaying it to a user. + viewport :: GoogleBoundingBox, + -- | If viewport is not applicable, bounds contain a more sensible bounding box. + bounds :: Maybe GoogleBoundingBox + } deriving (Show, Eq) +instance FromJSON Geometry where + parseJSON (Object v) = Geometry <$> + v .: "location" <*> + v .: "location_type" <*> + v .: "viewport" <*> + v .:? "bounds" + parseJSON _ = mempty + +-- | A Bounding box for a location. +data GoogleBoundingBox = GoogleBoundingBox { + -- | The north east location of the bounding box + northeast :: Location, + -- | The south west location of the bounding box + southwest :: Location +} deriving (Show, Eq, Generic) +instance FromJSON GoogleBoundingBox +instance GoogleArgumentListShow GoogleBoundingBox where + argListShow (GoogleBoundingBox ne sw) = argListShow ne ++ '|' : argListShow sw + + +-- | Abstraction of a geo location +data Location = Location { + -- | Latitude of the location + latitude :: Double, + -- | Longitude of the location + longitude :: Double + } deriving (Show, Eq) +instance GoogleArgumentListShow Location where + argListShow (Location lat long) = show lat ++ ',': show long + +instance FromJSON Location where + parseJSON (Object o) = Location <$> + o .: "lat" <*> + o .: "lng" + parseJSON _ = mempty + +-- | Takes a 'GoogleAnswer' and applies the function to the first 'GoogleResult'. +-- Returns a 'Left' with an error description if anything unexpected happens. +-- +-- For example, 'getLocation' uses this with +-- @ +-- ((latitude &&& longitude) . location . geometry) +-- @ +getProperty :: GoogleAnswer r -- ^ The answer to process. + -> (r -> a) -- ^ The function to be applied to the first (if any) result. + -> Either String a -- ^ Error or result of the function application +getProperty a f = case status a of + OK -> fromMaybe (Left "No results.") (results a >>= (\res -> case res of + (x:_) -> (Just . Right . f) x + _ -> Just $ Left "Empty resultset")) + otherwise -> Left (show otherwise ++ show (errorMessage a)) + + +-- | Gets the location from a 'GoogleAnswer', or returns an error. +getLocation :: GoogleAnswer GoogleResult -> Either String (Double, Double) +getLocation a = a `getProperty` ((latitude &&& longitude) . location . geometry) + +-- | Gets the formatted address from a GoogleAnswer (or an error) +getAddress :: GoogleAnswer GoogleResult -> Either String String +getAddress a = a `getProperty` formattedAddress + +-- | Parses a Lazy ByteString into a 'GoogleAnswer' or returns an error describing the problem. +parseAnswer :: LBS.ByteString -> Either String (GoogleAnswer GoogleResult) +parseAnswer = eitherDecode diff --git a/src/Network/Google/GeoResolver/Requester.hs b/src/Network/Google/GeoResolver/Requester.hs new file mode 100644 --- /dev/null +++ b/src/Network/Google/GeoResolver/Requester.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : GeoResolver.Requester +Description : Request helper definitions for Googles geocoding API. Using http-conduit. +Copyright : (c) 2015, Markenwerk, Jan Greve +License : MIT +Maintainer : jg@markenwerk.net +-} +module Network.Google.GeoResolver.Requester ( + -- * Data Types + GoogleRequest(..), + GoogleComponents(..), + GoogleLocationTypes(..), + GoogleResultTypes(..), + -- * Request methods + requestEncode, + requestDecode, + requestRaw, + requestRequest + + ) where + +import Network.HTTP.Types +import Network.HTTP.Conduit +import Blaze.ByteString.Builder +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Char8 as LBSC +import Data.Text (Text, append, pack) +import Network.Google.GeoResolver.Parser (GoogleBoundingBox(..), Location(..), GoogleArgumentListShow(..)) +import Data.Maybe +import Control.Arrow (second) +import Data.String (IsString(..)) + +-- | A Type abstracting possible API request argument combinations. +-- +-- For convenience, the 'IsString' instance generates a encoding request and assumes the String +-- is the address. +data GoogleRequest = + EncodingRequest { + encodeParameter :: Either String GoogleComponents, + encodeBounds :: Maybe GoogleBoundingBox, + encodeLanguage :: Maybe String, + encodeRegion :: Maybe String, + encodeKey :: Maybe String + } + | DecodingRequest { + decodeParameter :: Either Location String, + decodeKey :: Maybe String, + decodeLanguage :: Maybe String, + decodeResultType :: Maybe GoogleResultTypes, + decodeLocationType :: Maybe GoogleLocationTypes +} + +instance IsString GoogleRequest where + fromString s = EncodingRequest (Left s) Nothing Nothing Nothing Nothing + +instance GoogleArgumentList GoogleRequest where + argShow (EncodingRequest (Left addr) b l r k) = map (second fromJust) $ filter (isJust . snd) $ + zip + ["address", "bounds", "language", "region", "key"] + (fmap (fmap pack) [Just addr, fmap argListShow b, l, r, k]) + argShow (EncodingRequest (Right c) b l r k) = map (second fromJust) $ filter (isJust . snd) $ + zip + ["components", "bounds", "language", "region", "key"] + (fmap (fmap pack) [Just (argListShow c), fmap argListShow b, l, r, k]) + argShow (DecodingRequest (Left loc) k l rt lt) = map (second fromJust) $ filter (isJust . snd) $ + zip + ["latlng", "key", "language", "result_type", "location_type"] + (fmap (fmap pack) [Just (argListShow loc), k, l, fmap argListShow rt, fmap argListShow lt]) + argShow (DecodingRequest (Right pid) k l rt lt) = map (second fromJust) $ filter (isJust . snd) $ + zip + ["place_id", "key", "language", "result_type", "location_type"] + (fmap (fmap pack) [Just pid, k, l, fmap argListShow rt, fmap argListShow lt]) + +class GoogleArgumentList a where + argShow :: a -> [(Text, Text)] + + +-- | Abstraction for google's components +data GoogleComponents = Components [String] +instance GoogleArgumentListShow GoogleComponents where + argListShow (Components []) = "" + argListShow (Components (x : xs)) = x ++ concatMap ('|' :) xs + +-- | Abstraction for google's result types +data GoogleResultTypes = ResultTypes [String] +instance GoogleArgumentListShow GoogleResultTypes where + argListShow (ResultTypes []) = "" + argListShow (ResultTypes (x : xs)) = x ++ concatMap ('|' :) xs +-- | Abstraction for google's location types +data GoogleLocationTypes = LocationTypes [String] +instance GoogleArgumentListShow GoogleLocationTypes where + argListShow (LocationTypes []) = "" + argListShow (LocationTypes (x : xs)) = x ++ concatMap ('|' :) xs + + +baseURL :: Builder +baseURL = "https://maps.googleapis.com/maps/api/geocode/json" + +uriFromQueryPairs :: [(Text, Text)] -> LBS.ByteString +uriFromQueryPairs ps = toLazyByteString $ baseURL `mappend` query + where query = renderQueryBuilder True $ queryTextToQuery (map (second Just) ps) + +-- | Constructs the URI to be used for the web service +-- invocation from the input. Sends a request and +-- returns the Lazy ByteString from IO. +requestRaw :: [(Text, Text)] -> IO LBS.ByteString +requestRaw = simpleHttp . LBSC.unpack . uriFromQueryPairs + +uriFromAddress :: Maybe Text -> Text -> LBS.ByteString +uriFromAddress Nothing x = uriFromQueryPairs [("address",x)] +uriFromAddress (Just k) x = uriFromQueryPairs [("address",x), ("key", k)] + + +uriFromLocation :: Maybe Text -> (Double, Double) -> LBS.ByteString +uriFromLocation Nothing (lat, lng) = uriFromQueryPairs [("latlng", pack (show lat) `append` (pack $ ',':show lng))] +uriFromLocation (Just k) (lat, lng) = uriFromQueryPairs [("latlng", pack (show lat) `append` (pack $ ',':show lng)), ("key", k)] + +-- | Convenience function to request a given address. +requestEncode :: Maybe Text -> Text -> IO LBS.ByteString +requestEncode mk = simpleHttp . LBSC.unpack . uriFromAddress mk + +-- | Convenience function to request a given location. +requestDecode :: Maybe Text -> (Double, Double) -> IO LBS.ByteString +requestDecode mk = simpleHttp . LBSC.unpack . uriFromLocation mk + +-- | Sends a request based on a 'GoogleRequest'. +requestRequest :: GoogleRequest -> IO LBS.ByteString +requestRequest = simpleHttp . LBSC.unpack . uriFromQueryPairs . argShow diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,71 @@ +import Network.Google.GeoResolver +import Network.Google.GeoResolver.Parser +import Test.Framework (defaultMain, testGroup) +import Test.HUnit +import Test.HUnit.Base +import Test.Framework.Providers.HUnit +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.ByteString.Base64.Lazy (decodeLenient) +import Test.Framework.Providers.QuickCheck2 + +main :: IO () +main = defaultMain tests + + +tests = [ + + testGroup "Resolving (Encode)" + [testCase "Resolving Home" testResolvingHere, + testCase "Resolving Empty String" testResolvNowhere], + testGroup "Reverse resolving (Decoding)" + [ + testCase "Placeholder" ( True @=? True), + testCase "Placeholder 2" ( True @=? True), + testCase "Placeholder 3" ( True @=? True) + + + + ], + + testGroup "Parsing JSON" + [testCase "invalid JSON" testInvalid, + testCase "valid, but not sufficient" testValidMissing, + testCase "Google Example" testExample, + testCase "Google Example 2" testExample2 + ] + + + + + ] + +testInvalid = True @=? parserResult `hasLeft` (const True) + where parserResult = parseAnswer (LBS.pack "[}") + +testValidMissing = True @=? parserResult `hasLeft` (const True) + where parserResult = parseAnswer (LBS.pack "{\"not status\":\"OK\"}") + +testExample = True @=? parserResult `hasRight` (const True) + where parserResult = parseAnswer (decodeLenient $ LBS.pack "ew0KICAgInJlc3VsdHMiIDogWw0KICAgICAgew0KICAgICAgICAgImFkZHJlc3NfY29tcG9uZW50cyIgOiBbDQogICAgICAgICAgICB7DQogICAgICAgICAgICAgICAibG9uZ19uYW1lIiA6ICJTYW50YSBDcnV6IGRlIFRlbmVyaWZlIiwNCiAgICAgICAgICAgICAgICJzaG9ydF9uYW1lIiA6ICJTYW50YSBDcnV6IGRlIFRlbmVyaWZlIiwNCiAgICAgICAgICAgICAgICJ0eXBlcyIgOiBbICJsb2NhbGl0eSIsICJwb2xpdGljYWwiIF0NCiAgICAgICAgICAgIH0sDQogICAgICAgICAgICB7DQogICAgICAgICAgICAgICAibG9uZ19uYW1lIiA6ICJTYW50YSBDcnV6IGRlIFRlbmVyaWZlIiwNCiAgICAgICAgICAgICAgICJzaG9ydF9uYW1lIiA6ICJTYW50YSBDcnV6IGRlIFRlbmVyaWZlIiwNCiAgICAgICAgICAgICAgICJ0eXBlcyIgOiBbICJhZG1pbmlzdHJhdGl2ZV9hcmVhX2xldmVsXzQiLCAicG9saXRpY2FsIiBdDQogICAgICAgICAgICB9LA0KICAgICAgICAgICAgew0KICAgICAgICAgICAgICAgImxvbmdfbmFtZSIgOiAiQW5hZ2EiLA0KICAgICAgICAgICAgICAgInNob3J0X25hbWUiIDogIkFuYWdhIiwNCiAgICAgICAgICAgICAgICJ0eXBlcyIgOiBbICJhZG1pbmlzdHJhdGl2ZV9hcmVhX2xldmVsXzMiLCAicG9saXRpY2FsIiBdDQogICAgICAgICAgICB9LA0KICAgICAgICAgICAgew0KICAgICAgICAgICAgICAgImxvbmdfbmFtZSIgOiAiU2FudGEgQ3J1eiBkZSBUZW5lcmlmZSIsDQogICAgICAgICAgICAgICAic2hvcnRfbmFtZSIgOiAiVEYiLA0KICAgICAgICAgICAgICAgInR5cGVzIiA6IFsgImFkbWluaXN0cmF0aXZlX2FyZWFfbGV2ZWxfMiIsICJwb2xpdGljYWwiIF0NCiAgICAgICAgICAgIH0sDQogICAgICAgICAgICB7DQogICAgICAgICAgICAgICAibG9uZ19uYW1lIiA6ICJDYW5hcmlhcyIsDQogICAgICAgICAgICAgICAic2hvcnRfbmFtZSIgOiAiQ04iLA0KICAgICAgICAgICAgICAgInR5cGVzIiA6IFsgImFkbWluaXN0cmF0aXZlX2FyZWFfbGV2ZWxfMSIsICJwb2xpdGljYWwiIF0NCiAgICAgICAgICAgIH0sDQogICAgICAgICAgICB7DQogICAgICAgICAgICAgICAibG9uZ19uYW1lIiA6ICJTcGFpbiIsDQogICAgICAgICAgICAgICAic2hvcnRfbmFtZSIgOiAiRVMiLA0KICAgICAgICAgICAgICAgInR5cGVzIiA6IFsgImNvdW50cnkiLCAicG9saXRpY2FsIiBdDQogICAgICAgICAgICB9DQogICAgICAgICBdLA0KICAgICAgICAgImZvcm1hdHRlZF9hZGRyZXNzIiA6ICJTYW50YSBDcnV6IGRlIFRlbmVyaWZlLCBTYW50YSBDcnV6IGRlIFRlbmVyaWZlLCBTcGFpbiIsDQogICAgICAgICAiZ2VvbWV0cnkiIDogew0KICAgICAgICAgICAgImJvdW5kcyIgOiB7DQogICAgICAgICAgICAgICAibm9ydGhlYXN0IiA6IHsNCiAgICAgICAgICAgICAgICAgICJsYXQiIDogMjguNDg3NjE2LA0KICAgICAgICAgICAgICAgICAgImxuZyIgOiAtMTYuMjM1NjY0Ng0KICAgICAgICAgICAgICAgfSwNCiAgICAgICAgICAgICAgICJzb3V0aHdlc3QiIDogew0KICAgICAgICAgICAgICAgICAgImxhdCIgOiAyOC40MjgwMjQ4LA0KICAgICAgICAgICAgICAgICAgImxuZyIgOiAtMTYuMzM3MDA0NQ0KICAgICAgICAgICAgICAgfQ0KICAgICAgICAgICAgfSwNCiAgICAgICAgICAgICJsb2NhdGlvbiIgOiB7DQogICAgICAgICAgICAgICAibGF0IiA6IDI4LjQ2MzYyOTYsDQogICAgICAgICAgICAgICAibG5nIiA6IC0xNi4yNTE4NDY3DQogICAgICAgICAgICB9LA0KICAgICAgICAgICAgImxvY2F0aW9uX3R5cGUiIDogIkFQUFJPWElNQVRFIiwNCiAgICAgICAgICAgICJ2aWV3cG9ydCIgOiB7DQogICAgICAgICAgICAgICAibm9ydGhlYXN0IiA6IHsNCiAgICAgICAgICAgICAgICAgICJsYXQiIDogMjguNDg3NjE2LA0KICAgICAgICAgICAgICAgICAgImxuZyIgOiAtMTYuMjM1NjY0Ng0KICAgICAgICAgICAgICAgfSwNCiAgICAgICAgICAgICAgICJzb3V0aHdlc3QiIDogew0KICAgICAgICAgICAgICAgICAgImxhdCIgOiAyOC40MjgwMjQ4LA0KICAgICAgICAgICAgICAgICAgImxuZyIgOiAtMTYuMzM3MDA0NQ0KICAgICAgICAgICAgICAgfQ0KICAgICAgICAgICAgfQ0KICAgICAgICAgfSwNCiAgICAgICAgICJwbGFjZV9pZCIgOiAiQ2hJSmNVRWx6T3pNUVF3Ukx1VjMwbk1VRVVNIiwNCiAgICAgICAgICJ0eXBlcyIgOiBbICJsb2NhbGl0eSIsICJwb2xpdGljYWwiIF0NCiAgICAgIH0NCiAgIF0sDQogICAic3RhdHVzIiA6ICJPSyINCn0NCg==") + +testExample2 = True @=? parserResult `hasRight` (const True) + where parserResult = parseAnswer (decodeLenient $ LBS.pack "ew0KICAgInJlc3VsdHMiIDogWw0KICAgICAgew0KICAgICAgICAgImFkZHJlc3NfY29tcG9uZW50cyIgOiBbDQogICAgICAgICAgICB7DQogICAgICAgICAgICAgICAibG9uZ19uYW1lIiA6ICJBbm5lZ2F0YW4iLA0KICAgICAgICAgICAgICAgInNob3J0X25hbWUiIDogIkFubmVnYXRhbiIsDQogICAgICAgICAgICAgICAidHlwZXMiIDogWyAicm91dGUiIF0NCiAgICAgICAgICAgIH0sDQogICAgICAgICAgICB7DQogICAgICAgICAgICAgICAibG9uZ19uYW1lIiA6ICJIZWxzaW5nZm9ycyIsDQogICAgICAgICAgICAgICAic2hvcnRfbmFtZSIgOiAiSGVsc2luZ2ZvcnMiLA0KICAgICAgICAgICAgICAgInR5cGVzIiA6IFsgImFkbWluaXN0cmF0aXZlX2FyZWFfbGV2ZWxfMyIsICJwb2xpdGljYWwiIF0NCiAgICAgICAgICAgIH0sDQogICAgICAgICAgICB7DQogICAgICAgICAgICAgICAibG9uZ19uYW1lIiA6ICJGaW5sYW5kIiwNCiAgICAgICAgICAgICAgICJzaG9ydF9uYW1lIiA6ICJGSSIsDQogICAgICAgICAgICAgICAidHlwZXMiIDogWyAiY291bnRyeSIsICJwb2xpdGljYWwiIF0NCiAgICAgICAgICAgIH0NCiAgICAgICAgIF0sDQogICAgICAgICAiZm9ybWF0dGVkX2FkZHJlc3MiIDogIkFubmVnYXRhbiwgSGVsc2luZ2ZvcnMsIEZpbmxhbmQiLA0KICAgICAgICAgImdlb21ldHJ5IiA6IHsNCiAgICAgICAgICAgICJib3VuZHMiIDogew0KICAgICAgICAgICAgICAgIm5vcnRoZWFzdCIgOiB7DQogICAgICAgICAgICAgICAgICAibGF0IiA6IDYwLjE2ODk5NywNCiAgICAgICAgICAgICAgICAgICJsbmciIDogMjQuOTQyNzk1OQ0KICAgICAgICAgICAgICAgfSwNCiAgICAgICAgICAgICAgICJzb3V0aHdlc3QiIDogew0KICAgICAgICAgICAgICAgICAgImxhdCIgOiA2MC4xNjI2NjI3LA0KICAgICAgICAgICAgICAgICAgImxuZyIgOiAyNC45MzQNCiAgICAgICAgICAgICAgIH0NCiAgICAgICAgICAgIH0sDQogICAgICAgICAgICAibG9jYXRpb24iIDogew0KICAgICAgICAgICAgICAgImxhdCIgOiA2MC4xNjU3ODA4LA0KICAgICAgICAgICAgICAgImxuZyIgOiAyNC45Mzg0NTENCiAgICAgICAgICAgIH0sDQogICAgICAgICAgICAibG9jYXRpb25fdHlwZSIgOiAiR0VPTUVUUklDX0NFTlRFUiIsDQogICAgICAgICAgICAidmlld3BvcnQiIDogew0KICAgICAgICAgICAgICAgIm5vcnRoZWFzdCIgOiB7DQogICAgICAgICAgICAgICAgICAibGF0IiA6IDYwLjE2ODk5NywNCiAgICAgICAgICAgICAgICAgICJsbmciIDogMjQuOTQyNzk1OQ0KICAgICAgICAgICAgICAgfSwNCiAgICAgICAgICAgICAgICJzb3V0aHdlc3QiIDogew0KICAgICAgICAgICAgICAgICAgImxhdCIgOiA2MC4xNjI2NjI3LA0KICAgICAgICAgICAgICAgICAgImxuZyIgOiAyNC45MzQNCiAgICAgICAgICAgICAgIH0NCiAgICAgICAgICAgIH0NCiAgICAgICAgIH0sDQogICAgICAgICAicGxhY2VfaWQiIDogIkNoSUpBUlc3QzhzTGtrWVJnbDRqZTQtUlBVTSIsDQogICAgICAgICAidHlwZXMiIDogWyAicm91dGUiIF0NCiAgICAgIH0sDQogICAgICB7DQogICAgICAgICAiYWRkcmVzc19jb21wb25lbnRzIiA6IFsNCiAgICAgICAgICAgIHsNCiAgICAgICAgICAgICAgICJsb25nX25hbWUiIDogIkFubmV2w6RnZW4iLA0KICAgICAgICAgICAgICAgInNob3J0X25hbWUiIDogIkFubmV2w6RnZW4iLA0KICAgICAgICAgICAgICAgInR5cGVzIiA6IFsgInJvdXRlIiBdDQogICAgICAgICAgICB9LA0KICAgICAgICAgICAgew0KICAgICAgICAgICAgICAgImxvbmdfbmFtZSIgOiAiVmFuZGEiLA0KICAgICAgICAgICAgICAgInNob3J0X25hbWUiIDogIlZhbmRhIiwNCiAgICAgICAgICAgICAgICJ0eXBlcyIgOiBbICJhZG1pbmlzdHJhdGl2ZV9hcmVhX2xldmVsXzMiLCAicG9saXRpY2FsIiBdDQogICAgICAgICAgICB9LA0KICAgICAgICAgICAgew0KICAgICAgICAgICAgICAgImxvbmdfbmFtZSIgOiAiRmlubGFuZCIsDQogICAgICAgICAgICAgICAic2hvcnRfbmFtZSIgOiAiRkkiLA0KICAgICAgICAgICAgICAgInR5cGVzIiA6IFsgImNvdW50cnkiLCAicG9saXRpY2FsIiBdDQogICAgICAgICAgICB9LA0KICAgICAgICAgICAgew0KICAgICAgICAgICAgICAgImxvbmdfbmFtZSIgOiAiMDE0MjAiLA0KICAgICAgICAgICAgICAgInNob3J0X25hbWUiIDogIjAxNDIwIiwNCiAgICAgICAgICAgICAgICJ0eXBlcyIgOiBbICJwb3N0YWxfY29kZSIgXQ0KICAgICAgICAgICAgfQ0KICAgICAgICAgXSwNCiAgICAgICAgICJmb3JtYXR0ZWRfYWRkcmVzcyIgOiAiQW5uZXbDpGdlbiwgMDE0MjAgVmFuZGEsIEZpbmxhbmQiLA0KICAgICAgICAgImdlb21ldHJ5IiA6IHsNCiAgICAgICAgICAgICJib3VuZHMiIDogew0KICAgICAgICAgICAgICAgIm5vcnRoZWFzdCIgOiB7DQogICAgICAgICAgICAgICAgICAibGF0IiA6IDYwLjMyODI3MzgsDQogICAgICAgICAgICAgICAgICAibG5nIiA6IDI1LjExNjIxNjMNCiAgICAgICAgICAgICAgIH0sDQogICAgICAgICAgICAgICAic291dGh3ZXN0IiA6IHsNCiAgICAgICAgICAgICAgICAgICJsYXQiIDogNjAuMzI1NjQwMDk5OTk5OTksDQogICAgICAgICAgICAgICAgICAibG5nIiA6IDI1LjEwNzY0NzQNCiAgICAgICAgICAgICAgIH0NCiAgICAgICAgICAgIH0sDQogICAgICAgICAgICAibG9jYXRpb24iIDogew0KICAgICAgICAgICAgICAgImxhdCIgOiA2MC4zMjcxMDY5LA0KICAgICAgICAgICAgICAgImxuZyIgOiAyNS4xMTE4MDQ2DQogICAgICAgICAgICB9LA0KICAgICAgICAgICAgImxvY2F0aW9uX3R5cGUiIDogIkdFT01FVFJJQ19DRU5URVIiLA0KICAgICAgICAgICAgInZpZXdwb3J0IiA6IHsNCiAgICAgICAgICAgICAgICJub3J0aGVhc3QiIDogew0KICAgICAgICAgICAgICAgICAgImxhdCIgOiA2MC4zMjgzMDU5MzAyOTE1LA0KICAgICAgICAgICAgICAgICAgImxuZyIgOiAyNS4xMTYyMTYzDQogICAgICAgICAgICAgICB9LA0KICAgICAgICAgICAgICAgInNvdXRod2VzdCIgOiB7DQogICAgICAgICAgICAgICAgICAibGF0IiA6IDYwLjMyNTYwNzk2OTcwODQ5LA0KICAgICAgICAgICAgICAgICAgImxuZyIgOiAyNS4xMDc2NDc0DQogICAgICAgICAgICAgICB9DQogICAgICAgICAgICB9DQogICAgICAgICB9LA0KICAgICAgICAgInBhcnRpYWxfbWF0Y2giIDogdHJ1ZSwNCiAgICAgICAgICJwbGFjZV9pZCIgOiAiQ2hJSjNVSkNOdDRHa2tZUjgtX2E4RGgyNWtBIiwNCiAgICAgICAgICJ0eXBlcyIgOiBbICJyb3V0ZSIgXQ0KICAgICAgfSwNCiAgICAgIHsNCiAgICAgICAgICJhZGRyZXNzX2NvbXBvbmVudHMiIDogWw0KICAgICAgICAgICAgew0KICAgICAgICAgICAgICAgImxvbmdfbmFtZSIgOiAiQW5uZXBsYXRzZW4iLA0KICAgICAgICAgICAgICAgInNob3J0X25hbWUiIDogIkFubmVwbGF0c2VuIiwNCiAgICAgICAgICAgICAgICJ0eXBlcyIgOiBbICJyb3V0ZSIgXQ0KICAgICAgICAgICAgfSwNCiAgICAgICAgICAgIHsNCiAgICAgICAgICAgICAgICJsb25nX25hbWUiIDogIkhlbHNpbmdmb3JzIiwNCiAgICAgICAgICAgICAgICJzaG9ydF9uYW1lIiA6ICJIZWxzaW5nZm9ycyIsDQogICAgICAgICAgICAgICAidHlwZXMiIDogWyAiYWRtaW5pc3RyYXRpdmVfYXJlYV9sZXZlbF8zIiwgInBvbGl0aWNhbCIgXQ0KICAgICAgICAgICAgfSwNCiAgICAgICAgICAgIHsNCiAgICAgICAgICAgICAgICJsb25nX25hbWUiIDogIkZpbmxhbmQiLA0KICAgICAgICAgICAgICAgInNob3J0X25hbWUiIDogIkZJIiwNCiAgICAgICAgICAgICAgICJ0eXBlcyIgOiBbICJjb3VudHJ5IiwgInBvbGl0aWNhbCIgXQ0KICAgICAgICAgICAgfSwNCiAgICAgICAgICAgIHsNCiAgICAgICAgICAgICAgICJsb25nX25hbWUiIDogIjAwMTAwIiwNCiAgICAgICAgICAgICAgICJzaG9ydF9uYW1lIiA6ICIwMDEwMCIsDQogICAgICAgICAgICAgICAidHlwZXMiIDogWyAicG9zdGFsX2NvZGUiIF0NCiAgICAgICAgICAgIH0NCiAgICAgICAgIF0sDQogICAgICAgICAiZm9ybWF0dGVkX2FkZHJlc3MiIDogIkFubmVwbGF0c2VuLCAwMDEwMCBIZWxzaW5nZm9ycywgRmlubGFuZCIsDQogICAgICAgICAiZ2VvbWV0cnkiIDogew0KICAgICAgICAgICAgImJvdW5kcyIgOiB7DQogICAgICAgICAgICAgICAibm9ydGhlYXN0IiA6IHsNCiAgICAgICAgICAgICAgICAgICJsYXQiIDogNjAuMTY5NTY2NCwNCiAgICAgICAgICAgICAgICAgICJsbmciIDogMjQuOTM1NzEyNQ0KICAgICAgICAgICAgICAgfSwNCiAgICAgICAgICAgICAgICJzb3V0aHdlc3QiIDogew0KICAgICAgICAgICAgICAgICAgImxhdCIgOiA2MC4xNjg5OTcsDQogICAgICAgICAgICAgICAgICAibG5nIiA6IDI0LjkzNA0KICAgICAgICAgICAgICAgfQ0KICAgICAgICAgICAgfSwNCiAgICAgICAgICAgICJsb2NhdGlvbiIgOiB7DQogICAgICAgICAgICAgICAibGF0IiA6IDYwLjE2OTI3NDEsDQogICAgICAgICAgICAgICAibG5nIiA6IDI0LjkzNDgwMTYNCiAgICAgICAgICAgIH0sDQogICAgICAgICAgICAibG9jYXRpb25fdHlwZSIgOiAiR0VPTUVUUklDX0NFTlRFUiIsDQogICAgICAgICAgICAidmlld3BvcnQiIDogew0KICAgICAgICAgICAgICAgIm5vcnRoZWFzdCIgOiB7DQogICAgICAgICAgICAgICAgICAibGF0IiA6IDYwLjE3MDYzMDY4MDI5MTUxLA0KICAgICAgICAgICAgICAgICAgImxuZyIgOiAyNC45MzYyMDUyMzAyOTE1DQogICAgICAgICAgICAgICB9LA0KICAgICAgICAgICAgICAgInNvdXRod2VzdCIgOiB7DQogICAgICAgICAgICAgICAgICAibGF0IiA6IDYwLjE2NzkzMjcxOTcwODUsDQogICAgICAgICAgICAgICAgICAibG5nIiA6IDI0LjkzMzUwNzI2OTcwODUNCiAgICAgICAgICAgICAgIH0NCiAgICAgICAgICAgIH0NCiAgICAgICAgIH0sDQogICAgICAgICAicGFydGlhbF9tYXRjaCIgOiB0cnVlLA0KICAgICAgICAgInBsYWNlX2lkIiA6ICJDaElKZWFoTXFzd0xra1lSMnZRZkcxbkhJM00iLA0KICAgICAgICAgInR5cGVzIiA6IFsgInJvdXRlIiBdDQogICAgICB9DQogICBdLA0KICAgInN0YXR1cyIgOiAiT0siDQp9DQo=") + +testResolvingHere :: Assertion +testResolvingHere = do + result <- geoEncode Nothing "Lornsenstraße 43\nKiel" + True @=? result `hasRight` (\(lat, long) -> and [lat < 55, lat > 54, long < 11, long > 10]) + +testResolvNowhere :: Assertion +testResolvNowhere = do + result <- geoEncode Nothing "" + False @=? result `hasLeft` (\x -> x == "INVALID_REQUEST") + + +hasRight :: Either a b -> (b -> Bool) -> Bool +(Left _) `hasRight` _ = False +(Right x) `hasRight` f = f x + +hasLeft :: Either a b -> (a -> Bool) -> Bool +(Right _) `hasLeft` _ = False +(Left x) `hasLeft` f = f x