diff --git a/GoogleDirections.cabal b/GoogleDirections.cabal new file mode 100644 --- /dev/null +++ b/GoogleDirections.cabal @@ -0,0 +1,64 @@ +-- GoogleDirections.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: GoogleDirections + +-- 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.0.0 + +-- A short (one-line) description of the package. +Synopsis: Haskell Interface to Google Directions API + +-- A longer description of the package. +Description: An interface to the Google Directions API + +-- The license under which the package is released. +License: BSD3 + +-- The file containing the license text. +License-file: LICENSE + +-- The package author(s). +Author: Favil Orbedios + +-- An email address to which users can send suggestions, bug reports, +-- and patches. +Maintainer: Favil Orbedios + +-- A copyright notice. +Copyright: (c) 2010 Favil Orbedios + +Category: Network + +Build-type: Simple + +-- Extra files to be distributed with the package, such as examples or +-- a README. +Extra-source-files: README + +-- Constraint on the version of Cabal needed to build this package. +Cabal-version: >=1.2 + + +Library + -- Modules exported by the library. + Exposed-modules: Google.Directions + hs-source-dirs: src + + -- Packages needed in order to build this package. + Build-depends: containers + , bytestring + , dataenc + , base >=4 && <5 + , AttoJson + , download-curl + + -- Modules not exported by this package. + -- Other-modules: + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. + -- Build-tools: + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2010, Favil Orbedios + +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 Favil Orbedios 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/README b/README new file mode 100644 --- /dev/null +++ b/README 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/src/Google/Directions.hs b/src/Google/Directions.hs new file mode 100644 --- /dev/null +++ b/src/Google/Directions.hs @@ -0,0 +1,307 @@ +-- Author: Favil Orbedios +-- Maintainer: Favil Orbedios +-- +-- Copyright (C) 2010 Favil Orbedios, all rights reserved. +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- any later version. +-- +-- This program is distributed in the hope that it will be useful, + -- but WITHOUT ANY WARRANTY; without even the implied warranty of + -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + -- GNU General Public License for more details. + -- + -- You should have received a copy of the GNU General Public License + -- along with this program. If not, see . + +{-# LANGUAGE OverloadedStrings, FlexibleInstances #-} +module Google.Directions ( + TravelMode (..), + directions, + Waypoints (..), + Avoidable (..), + Units (..), + Directions (..), + Route (..), + Distance (..), + Duration (..), + Coord, + Leg (..), + Step (..), + PolyLine (..), + StatusCode (..), + ) where + +import Network.Curl.Download +import Text.JSON.AttoJSON as JSON +import Data.Ratio + +import qualified Codec.Binary.Url as C +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as S +import qualified Data.Map as M + + +data TravelMode = Driving + | Walking + | Bicycling + +instance Show TravelMode where + show Driving = "driving" + show Walking = "walking" + show Bicycling = "bicycling" + +data Waypoints = Waypoints Bool [B.ByteString] + +instance Show Waypoints where + show (Waypoints _ []) = "" + show (Waypoints optimize points) = + "&waypoints=" + ++ (if optimize then "optimize:true|" + else "") + ++ showWaypoints points + where + showWaypoints [point] = C.encode (B.unpack point) + showWaypoints (p:ps) = C.encode (B.unpack p) ++ "|" ++ showWaypoints ps + +data Avoidable = Tolls + | Highways + +instance Show Avoidable where + show Tolls = "avoid=tolls" + show Highways = "avoid=highways" + +showAvoidables [] = "" +showAvoidables as = '&':show' as + where show' [a] = show a + show' (a:as) = show a ++ showAvoidables as + +data Units = Imperial + | Metric + +data Directions = Directions { + status :: StatusCode, + routes :: [Route] +} deriving (Show) + +data Route = Route { + summary :: B.ByteString, + legs :: [Leg], + waypointOrder :: [Integer], + --overviewPolyline :: PolyLine, + copyrights :: B.ByteString, + warnings :: [B.ByteString] +} deriving (Show) + +data Distance = Dist Double B.ByteString deriving (Show) +data Duration = Dur Double B.ByteString deriving (Show) +type Coord = (Double, Double) + +data Leg = Leg { + steps :: [Step], + legDistance :: Distance, + legDuration :: Duration, + legStartLocation :: Coord, + legEndLocation :: Coord, + startAddress :: B.ByteString, + endAddress :: B.ByteString +} deriving (Show) + +data Step = Step { + htmlInstructions :: B.ByteString, + stepDistance :: Distance, + stepDuration :: Duration, + stepStartLocation :: Coord, + stepEndLocation :: Coord +} deriving (Show) + +data PolyLine = PolyLine { + points :: B.ByteString, + levels :: B.ByteString +} deriving (Show) + +data StatusCode = OK + | NotFound + | ZeroResults + | MaxWaypointsExceeded + | InvalidRequest + | OverQueryLimit + | RequestDenied + | UnknownError + deriving (Show) + +directions :: + B.ByteString -- The origin address + -> B.ByteString -- The destination address + -> Maybe TravelMode -- The mode of transport to use + -> Maybe Waypoints -- Should google alter a route with waypoints + -> Bool -- Should google search for alternate routes + -> [Avoidable] -- Should google avoid tolls and/or highways + -> Maybe Units -- the unit system to use + -> Bool -- sensor + -> IO (Either String Directions) +directions origin dest travelMode + waypoints alternate + avoidables units sensor = do + let url = "http://maps.googleapis.com/maps/api/directions/json?" + ++ ("origin=" ++ C.encode (B.unpack origin)) + ++ ("&destination=" ++ C.encode (B.unpack dest)) + ++ (case travelMode of + Nothing -> "" + Just mode -> "&mode=" ++ show mode + ) + ++ (case waypoints of + Nothing -> "" + Just points -> (show points) + ) + ++ "&alternates=" ++ if alternate then "true" else "false" + ++ showAvoidables avoidables + ++ (case units of + Nothing -> "" + Just Imperial -> "&units=imperial" + Just Metric -> "&units=metric" + ) + ++ "&sensor=" ++ if sensor then "true" else "false" + string <- openURI url + --putStrLn $ show string + return $ parseDirections string + +parseDirections (Left err) = Left err +parseDirections (Right json) = + case parseJSON json of + Left err -> Left err + Right jsvalue -> + parseDirections' jsvalue + +parseDirections' jsvalue = case JSON.lookup "status" jsvalue of + Just (JSString str) -> Right $ Directions (parseStatus str) + (parseRoutes $ JSON.lookup "routes" jsvalue) + _ -> Left "error, can't parse" + +parseStatus "OK" = OK +parseStatus "NOT_FOUND" = NotFound +parseStatus "ZERO_RESULTS" = ZeroResults +parseStatus "MAX_WAYPOINTS_EXCEEDED" = MaxWaypointsExceeded +parseStatus "INVALID_REQUEST" = InvalidRequest +parseStatus "OVER_QUERY_LIMIT" = OverQueryLimit +parseStatus "REQUEST_DENIED" = RequestDenied +parseStatus _ = UnknownError + +parseRoutes :: Maybe JSValue -> [Route] +parseRoutes routes = case routes of + Just (JSArray jsRoutes) -> map parseRoute jsRoutes + _ -> [] + +parseRoute route = Route + (case JSON.lookup "summary" route of + Just (JSString sum) -> sum + _ -> error "summary parse failed" + ) + (case JSON.lookup "legs" route of + Just (JSArray legs) -> map parseLeg legs + _ -> error "legs parse failed" + ) + (case JSON.lookup "waypoint_order" route of + Just (JSArray warns) -> map + (\warn -> + (case warn of + JSNumber n -> numerator n + _ -> error "warning parse failed" + ) + ) warns + _ -> error "warnings parse failed" + ) + (case JSON.lookup "copyrights" route of + Just (JSString s) -> s + _ -> error "copyrights parse failed" + ) + (case JSON.lookup "warnings" route of + Just (JSArray warns) -> map + (\warn -> + (case warn of + JSString s -> s + _ -> error "warning parse failed" + ) + ) warns + _ -> error "warnings parse failed" + ) + +parseLeg :: JSValue -> Leg +parseLeg leg = Leg + (case JSON.lookup "steps" leg of + Just (JSArray stps) -> map parseStep stps + _ -> error "step parse failed" + ) + (case JSON.lookup "distance" leg of + Just (JSObject m) -> parseDistance m + _ -> error "distance parse failed" + ) + (case JSON.lookup "duration" leg of + Just (JSObject m) -> parseDuration m + _ -> error "duration parse failed" + ) + (case JSON.lookup "start_location" leg of + Just (JSObject m) -> parseLocation m + _ -> error "start_location parse failed" + ) + (case JSON.lookup "end_location" leg of + Just (JSObject m) -> parseLocation m + _ -> error "end_location parse failed" + ) + (case JSON.lookup "start_address" leg of + Just (JSString string) -> string + _ -> error "start_address parse failed" + ) + (case JSON.lookup "end_address" leg of + Just (JSString string) -> string + _ -> error "end_address parse failed" + ) + +parseStep :: JSValue -> Step +parseStep step = Step + (case JSON.lookup "html_instructions" step of + Just (JSString string) -> string + _ -> error "html_instructions parse failed" + ) + (case JSON.lookup "distance" step of + Just (JSObject m) -> parseDistance m + _ -> error "distance parse failed" + ) + (case JSON.lookup "duration" step of + Just (JSObject m) -> parseDuration m + _ -> error "duration parse failed" + ) + (case JSON.lookup "start_location" step of + Just (JSObject m) -> parseLocation m + _ -> error "start_location parse failed" + ) + (case JSON.lookup "end_location" step of + Just (JSObject m) -> parseLocation m + _ -> error "end_location parse failed" + ) + +parseDistance m = Dist + (case m M.! "value" of + JSNumber n -> fromRational n + _ -> error "value parse failed" + ) + (case m M.! "text" of + JSString s -> s + _ -> error "text parse failed" + ) +parseDuration m = Dur + (case m M.! "value" of + JSNumber n -> fromRational n + _ -> error "value parse failed" + ) + (case m M.! "text" of + JSString s -> s + _ -> error "text parse failed" + ) +parseLocation m = + (case m M.! "lat" of + JSNumber n -> fromRational n, + case m M.! "lat" of + JSNumber n -> fromRational n)