diff --git a/Geography/Directions/Google.hs b/Geography/Directions/Google.hs new file mode 100644 --- /dev/null +++ b/Geography/Directions/Google.hs @@ -0,0 +1,65 @@ +module Geography.Directions.Google where + +import Geography.Geocoding.Google.Get +import qualified Text.HJson as J +import qualified Data.Map as M +import Network.URI (parseURI) +import Network.HTTP (urlEncodeVars) +import Data.Maybe (fromMaybe) +import Text.Printf (printf) +import Data.List (intersperse) + +type DirectionsError = String + +data TravelMode = Driving | Walking | Bicycling deriving (Eq) +instance Show TravelMode where show Driving = "driving"; show Walking = "walking"; show Bicycling = "bicycling" +data Avoid = Tolls | Highways deriving (Eq) +instance Show Avoid where show Tolls = "tolls"; show Highways = "highways" +data UnitSystem = Metric | Imperial deriving (Eq) +instance Show UnitSystem where show Metric = "metric"; show Imperial = "imperial" + +data DirOptions = DirOptions { travelMode :: TravelMode + , avoid :: Maybe Avoid + , waypoints :: [String] + , alternatives :: Bool + , units :: Maybe UnitSystem + , regionCode :: Maybe String + , sensor :: Bool } + deriving Show + +-- | Convenient set of default options to getDirections +defaultDirOptions = DirOptions Driving Nothing [] False Nothing Nothing False + +-- | Find directions from origin to destination using set of options +getDirections :: String -> String -> DirOptions -> IO (Either DirectionsError J.Json) +getDirections orig dest opts = do + case parseURI (mkDirectionsURL orig dest opts) of + Nothing -> return (Left "URL encoding error") + Just uri -> do + jstring <- fromMaybe "" `fmap` maybeGet uri + case J.fromString jstring of + Left e -> return $ Left (show e) + Right js + | getStatus js /= "OK" -> return . Left $ getStatus js + | otherwise -> return $ fromMaybe (Left "Malformed JSON") (Just (Right js)) + +directionsURLFormat = "http://maps.googleapis.com/maps/api/directions/json?%s" +mkDirectionsURL :: String -> String -> DirOptions -> String +mkDirectionsURL orig dest opts = + printf directionsURLFormat $ + urlEncodeVars ([ ("origin", orig) + , ("destination", dest) + , ("sensor", showBool (sensor opts)) + , ("alternatives", showBool (alternatives opts)) ] ++ + (case avoid opts of Just av -> [("avoid", show av)] ; _ -> []) ++ + (case units opts of Just us -> [("units", show us)] ; _ -> []) ++ + (case regionCode opts of Just rc -> [("regionCode", show rc)]; _ -> []) ++ + (case waypoints opts of [] -> []; wp -> [("waypoints", wp2s wp)]) + ) + where wp2s = concat . intersperse "|" + showBool True = "true"; showBool False = "false" + +getStatus :: J.Json -> String +getStatus (J.JObject top) = fromMaybe "Parse error" $ do + J.JString s <- M.lookup "status" top + return s diff --git a/Geography/Geocoding/Google.hs b/Geography/Geocoding/Google.hs new file mode 100644 --- /dev/null +++ b/Geography/Geocoding/Google.hs @@ -0,0 +1,80 @@ +-- | Google Geocoding interface. Please read +-- +module Geography.Geocoding.Google (geoEncode, geoDecode, GeocodeError) where + +import qualified Text.HJson as J +import qualified Data.Map as M +import Geography.Geocoding.Google.Get +import Network.URI (parseURI) +import Network.HTTP (urlEncodeVars) +import Data.Maybe (fromMaybe) +import Text.Printf (printf) + +type GeocodeError = String + +-- | Convert an address into a latitude, longitude pair. +geoEncode :: String -> IO (Either GeocodeError (Double, Double)) +geoEncode a = do + case parseURI (mkGeoEncodeURL a) of + Nothing -> return (Left "URL encoding error") + Just uri -> do + jstring <- fromMaybe "" `fmap` maybeGet uri + case J.fromString jstring of + Left e -> return $ Left (show e) + Right js + | getStatus js /= "OK" -> return . Left $ getStatus js + | otherwise -> return $ fromMaybe (Left "Malformed JSON") (Right `fmap` findLatLon js) + +-- | Convert a latitude, longitude pair into a street address. +geoDecode :: (Double, Double) -> IO (Either GeocodeError String) +geoDecode ll = do + case parseURI (mkGeoDecodeURL ll) of + Nothing -> return (Left "URL encoding error") + Just uri -> do + jstring <- fromMaybe "" `fmap` maybeGet uri + case J.fromString jstring of + Left e -> return $ Left (show e) + Right js + | getStatus js /= "OK" -> return . Left $ getStatus js + | otherwise -> return $ fromMaybe (Left "Malformed JSON") (Right `fmap` findAddress js) + +getStatus :: J.Json -> String +getStatus (J.JObject top) = fromMaybe "Parse error" $ do + J.JString s <- M.lookup "status" top + return s + +findLatLon :: J.Json -> Maybe (Double, Double) +findLatLon (J.JObject top) = do + J.JArray res <- M.lookup "results" top + searchJArray res "geometry" $ \ (J.JObject geo) -> do + J.JObject loc <- M.lookup "location" geo + J.JNumber lat <- M.lookup "lat" loc + J.JNumber lon <- M.lookup "lng" loc + return (fromRational lat, fromRational lon) + +findAddress :: J.Json -> Maybe String +findAddress (J.JObject top) = do + J.JArray res <- M.lookup "results" top + searchJArray res "formatted_address" $ \ (J.JString fma) -> return fma + +geocodeURLFormat = "http://maps.googleapis.com/maps/api/geocode/json?%s" +mkGeoEncodeURL :: String -> String +mkGeoEncodeURL a = + printf geocodeURLFormat $ urlEncodeVars [("address", a), ("sensor", "false")] +mkGeoDecodeURL :: (Double, Double) -> String +mkGeoDecodeURL (lat, lng) = + printf geocodeURLFormat $ urlEncodeVars [("latlng", ll), ("sensor", "false")] + where ll = show lat ++ "," ++ show lng + +searchJArray a name f = + flip findJust a $ \ x -> + case x of J.JObject m -> do + y <- M.lookup name m + f y + _ -> Nothing + +findJust :: (a -> Maybe b) -> [a] -> Maybe b +findJust f [] = Nothing +findJust f (x:xs) = case f x of + (y@ (Just _)) -> y + Nothing -> findJust f xs diff --git a/Geography/Geocoding/Google/Get.hs b/Geography/Geocoding/Google/Get.hs new file mode 100644 --- /dev/null +++ b/Geography/Geocoding/Google/Get.hs @@ -0,0 +1,50 @@ +-- | Some handy functions for retrieving a web-page. +module Geography.Geocoding.Google.Get (get, maybeGet, eitherGet, timeoutGet) where + +import Data.Char (intToDigit) +import Control.Concurrent ( threadDelay, newEmptyMVar, myThreadId + , forkIO, putMVar, killThread, takeMVar ) +import Network.HTTP ( simpleHTTP, insertHeaders, Header (..), HeaderName (..) + , Request (..), RequestMethod (..), rspBody ) +import Network.URI (parseURI, URI) +import System.Environment (getArgs) +import System.Exit (exitFailure) +import System.IO (hPutStrLn, stderr) +import Control.Exception (catch, SomeException) + +err :: String -> IO a +err msg = do + hPutStrLn stderr msg + exitFailure + +get :: URI -> IO String +get uri = do + eresp <- simpleHTTP $ insertHeaders [Header HdrAccept "*/*"] + (Request uri GET [] "") + case eresp of + Left er -> fail $ show er + Right res -> return $ rspBody res + +maybeGet :: URI -> IO (Maybe String) +maybeGet uri = either (const Nothing) Just `fmap` eitherGet uri + +eitherGet :: URI -> IO (Either String String) +eitherGet uri = timeoutGet uri + +-- 5 sec +waitTimeout = 10000000 + +timeoutGet :: URI -> IO (Either String String) +timeoutGet uri = do + mv <- newEmptyMVar + mid <- myThreadId + tid1 <- forkIO $ do + x <- get uri + putMVar mv $ Right x + `catch` (\ e -> putMVar mv . Left . show $ (e :: SomeException)) + tid2 <- forkIO $ do + threadDelay waitTimeout + killThread tid1 + putMVar mv (Left "timeout") + takeMVar mv + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2011-2015, Matthew Danish + +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 Matthew Danish 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/geocode-google.cabal b/geocode-google.cabal new file mode 100644 --- /dev/null +++ b/geocode-google.cabal @@ -0,0 +1,60 @@ +-- geocode-google.cabal auto-generated by cabal init. For additional +-- options, see +-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. +-- The name of the package. +Name: geocode-google + +-- The package version. See the Haskell package versioning policy +-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for +-- standards guiding when and how versions should be incremented. +Version: 0.3 + +-- A short (one-line) description of the package. +Synopsis: Geocoding using the Google Web API + +-- A longer description of the package. +-- Description: + +-- URL for the project homepage or repository. +Homepage: http://github.com/mrd/geocode-google + +-- The license under which the package is released. +License: BSD3 + +-- The file containing the license text. +License-file: LICENSE + +-- The package author(s). +Author: Matthew Danish + +-- An email address to which users can send suggestions, bug reports, +-- and patches. +Maintainer: mrd@debian.org + +-- A copyright notice. +-- Copyright: + +Category: Geography + +Build-type: Simple + +-- Extra files to be distributed with the package, such as examples or +-- a README. +-- Extra-source-files: + +-- Constraint on the version of Cabal needed to build this package. +Cabal-version: >=1.2 + + +Library + -- Modules exported by the library. + Exposed-modules: Geography.Geocoding.Google, Geography.Directions.Google + + -- Packages needed in order to build this package. + Build-depends: base >= 4 && < 5, HTTP, network, containers, hjson, network-uri + + -- Modules not exported by this package. + Other-modules: Geography.Geocoding.Google.Get + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. + -- Build-tools: