packages feed

geocode-google (empty) → 0.3

raw patch · 6 files changed

+287/−0 lines, 6 filesdep +HTTPdep +basedep +containerssetup-changed

Dependencies added: HTTP, base, containers, hjson, network, network-uri

Files

+ Geography/Directions/Google.hs view
@@ -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
+ Geography/Geocoding/Google.hs view
@@ -0,0 +1,80 @@+-- | Google Geocoding interface. Please read+-- <URL: http://code.google.com/apis/maps/documentation/geocoding/>+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
+ Geography/Geocoding/Google/Get.hs view
@@ -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+
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ geocode-google.cabal view
@@ -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: