google-static-maps (empty) → 0.1.0.0
raw patch · 4 files changed
+657/−0 lines, 4 filesdep +JuicyPixelsdep +basedep +bytedumpsetup-changed
Dependencies added: JuicyPixels, base, bytedump, http-client, servant, servant-JuicyPixels, servant-client, text
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- google-static-maps.cabal +39/−0
- src/Web/Google/Static/Maps.hs +586/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ google-static-maps.cabal view
@@ -0,0 +1,39 @@+name: google-static-maps+version: 0.1.0.0+synopsis: Bindings to the Google Static Maps API+description: The <https://developers.google.com/maps/documentation/static-maps/intro Google Static Maps API>+ returns a map as an image via an HTTP request. This library+ provides bindings in Haskell to that API.+ .+ NB: The use of the Google Static Maps API services is+ subject to the <https://developers.google.com/maps/terms Google Maps APIs Terms of Service>,+ which terms restrict the use of content.+ .+ This package has no connection with Google Inc. or its+ affiliates.+homepage: https://github.com/mpilgrem/google-static-maps#readme+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.Static.Maps+ build-depends: base >= 4.7 && < 5+ , bytedump >= 1.0 && < 1.1+ , http-client >= 0.5 && < 0.6+ , JuicyPixels >= 3.2 && < 3.3+ , servant >= 0.9 && < 0.10+ , servant-client >= 0.9 && < 0.10+ , servant-JuicyPixels >= 0.3 && < 0.4+ , text >= 1.2 && < 1.3+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/mpilgrem/google-static-maps
+ src/Web/Google/Static/Maps.hs view
@@ -0,0 +1,586 @@+{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : Web.Google.Static.Maps +-- Description : Bindings to the Google Static Maps API +-- Copyright : (c) Mike Pilgrem 2017 +-- Maintainer : public@pilgrem.com +-- Stability : experimental +-- +-- This module has no connection with Google Inc. or its affiliates. +-- +-- The <https://developers.google.com/maps/documentation/static-maps/intro Google Static Maps API> +-- returns a map as an image via an HTTP request. This library provides bindings +-- in Haskell to that API. +-- +-- NB: The use of the Google Static Maps API services is subject to the +-- <https://developers.google.com/maps/terms Google Maps APIs Terms of Service>, +-- which terms restrict the use of content. +-- +-- The following are not yet implemented: certain optional parameters +-- ('language', 'region' and 'signature'); address locations; non-PNG image +-- formats; custom marker icons; and encoded polyline paths. +-- +-- The code below is an example console application to test the use of the +-- library with the Google Static Maps API. +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > module Main (main) where +-- > +-- > import Codec.Picture.Saving (imageToPng) -- package JuicyPixels +-- > import qualified Data.ByteString.Lazy as B (writeFile) +-- > import Data.Maybe (fromJust) +-- > import Graphics.Gloss (Display (..), display, white) -- package gloss +-- > import Graphics.Gloss.Juicy (fromDynamicImage) -- package gloss-juicy +-- > import Network.HTTP.Client (newManager) +-- > import Network.HTTP.Client.TLS (tlsManagerSettings) +-- > import Web.Google.Static.Maps (Center (..), Key (..), Location (..), Size (..), +-- > staticmap, StaticmapResponse (..), Zoom (..)) +-- > +-- > main :: IO () +-- > main = do +-- > putStrLn "A test of the Google Static Maps API.\nNB: The use of the \ +-- > \API services is subject to the Google Maps APIs Terms of Serivce \ +-- > \at https://developers.google.com/maps/terms.\n" +-- > mgr <- newManager tlsManagerSettings +-- > let apiKey = Key "<REPLACE_THIS_WITH_YOUR_ACTUAL_GOOGLE_API_KEY>" +-- > center = Just $ Center (Location 42.165950 (-71.362015)) +-- > zoom = Just $ Zoom 17 +-- > w = 400 +-- > h = 400 +-- > size = Size w h +-- > result <- staticmap mgr apiKey center zoom size Nothing Nothing [] +-- > Nothing [] [] Nothing +-- > case result of +-- > Right response -> do +-- > let picture = fromJust $ fromDynamicImage response +-- > title = "Test Google Static Maps API" +-- > window = InWindow title (w, h) (10, 10) +-- > display window white picture +-- > Left err -> putStrLn $ "Error! Result:\n" ++ show err +module Web.Google.Static.Maps + ( -- * Functions + staticmap + -- * API + , GoogleStaticMapsAPI + , api + -- * Types + , Key (..) + , Center (..) + , Location (..) + , Zoom (..) + , Size (..) + , Scale (..) + , Format (..) + , MapType (..) + , MapStyle (..) + , Feature (..) + , Element (..) + , MapStyleOp (..) + , Visibility (..) + , Markers (..) + , MarkerStyle (..) + , MarkerSize (..) + , MarkerColor (..) + , MarkerLabel (..) + , StdColor (..) + , Path (..) + , PathStyle (..) + , PathWeight (..) + , PathColor (..) + , PathGeodesic (..) + , Visible (..) + , StaticmapResponse + ) where + +import Codec.Picture.Types (DynamicImage (..)) +import Data.List (intersperse) +import Data.Maybe (catMaybes) +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import qualified Data.Text as T (append, concat, pack) +import Data.Word (Word8) +import Network.HTTP.Client (Manager) +import Servant.API ((:>), Get, QueryParam, QueryParams, ToHttpApiData (..)) +import Servant.Client (BaseUrl (..), client, ClientEnv (..), ClientM, + runClientM, Scheme (..), ServantError) +import Servant.JuicyPixels (PNG) +import Text.Bytedump (hexString) + +-- | API key +newtype Key = Key Text + deriving (Eq, Show, ToHttpApiData) + +-- | Center of the map: not required if the map includes markers or paths. +newtype Center = Center Location + deriving (Eq, Show, ToHttpApiData) + +-- | Location +data Location = Location + { lat :: Double -- ^ Takes any value between -90 and 90. + , lng :: Double -- ^ Takes any value between -180 and 180. + } deriving (Eq, Show) + +instance ToHttpApiData Location where + toUrlPiece (Location lat' lng') = T.pack (show lat' ++ "," ++ show lng') + +instance ToHttpApiData [Location] where + toUrlPiece [] = "" + toUrlPiece ls = T.concat $ intersperse pipe $ map toUrlPiece ls + where + pipe = toUrlPiece ("|" :: Text) + +-- | Zoom level: the lowest level, in which the whole world can be seen, is 0. +-- Each succeeding level doubles the precision. Not required if the map includes +-- markers or paths. +newtype Zoom = Zoom Int + deriving (Eq, Show, ToHttpApiData) + +-- | Size in pixels: there are maximum allowable values. +data Size = Size + { width :: Int + , height :: Int + } deriving (Eq, Show) + +instance ToHttpApiData Size where + toUrlPiece (Size width' height') = + T.pack (show width' ++ "x" ++ show height') + +-- | Scale +data Scale + = Single -- ^ The default value. + | Double + | Quadruple + deriving (Eq, Show) + +instance ToHttpApiData Scale where + toUrlPiece scale = case scale of + Single -> "1" + Double -> "2" + Quadruple -> "4" + +-- | Image format +data Format + = Png8 -- ^ The default value. + | Png32 + deriving (Eq, Show) + +instance ToHttpApiData Format where + toUrlPiece format = case format of + Png8 -> "png8" + Png32 -> "png32" + +-- | Map type +data MapType + = RoadMap -- ^ The default value. + | Satellite + | Hybrid + | Terrain + deriving (Eq, Show) + +instance ToHttpApiData MapType where + toUrlPiece mapType = case mapType of + RoadMap -> "roadmap" + Satellite -> "satellite" + Hybrid -> "hybrid" + Terrain -> "terrain" + +-- | MapStyle +data MapStyle = MapStyle (Maybe Feature) (Maybe Element) [MapStyleOp] + deriving (Eq, Show) + +instance ToHttpApiData MapStyle where + toUrlPiece (MapStyle featureOpt elementOpt ops) = + T.concat $ intersperse pipe $ catMaybes [featureUrl, elementUrl] ++ + [opsUrl] + where + pipe = toUrlPiece ("|" :: Text) + featureUrl = T.append "feature:" . toUrlPiece <$> featureOpt + elementUrl = T.append "element:" . toUrlPiece <$> elementOpt + opsUrl = toUrlPiece ops + +-- | Map feature +data Feature + = AllFeatures + | Administrative + | AdministrativeCountry + | AdministrativeLandParcel + | AdministrativeLocality + | AdministrativeNeighborhood + | AdministrativeProvince + | Landscape + | LandscapeManMade + | LandscapeNatural + | LandscapeNaturalLandcover + | LandscapeNaturalTerrain + | Poi + | PoiAttraction + | PoiBusiness + | PoiGovernment + | PoiMedical + | PoiPark + | PoiPlaceOfWorship + | PoiSchool + | PoiSportsComplex + | Road + | RoadArterial + | RoadHighway + | RoadHighwayControlledAccess + | RoadLocal + | Transit + | TransitLine + | TransitStation + | TransitStationAirport + | TransitStationBus + | TransitStationRail + | Water + deriving (Eq) + +instance Show Feature where + show feature = case feature of + AllFeatures -> "all" + Administrative -> "administrative" + AdministrativeCountry -> "administrative.country" + AdministrativeLandParcel -> "administrative.land_parcel" + AdministrativeLocality -> "administrative.locality" + AdministrativeNeighborhood -> "administrative.neighborhood" + AdministrativeProvince -> "administrative.province" + Landscape -> "landscape" + LandscapeManMade -> "landscape.man_made" + LandscapeNatural -> "landscape.natural" + LandscapeNaturalLandcover -> "landscape.landcover" + LandscapeNaturalTerrain -> "landscape.terrain" + Poi -> "poi" + PoiAttraction -> "poi.attraction" + PoiBusiness -> "poi.business" + PoiGovernment -> "poi.government" + PoiMedical -> "poi.medical" + PoiPark -> "poi.park" + PoiPlaceOfWorship -> "poi.place_of_worship" + PoiSchool -> "poi.school" + PoiSportsComplex -> "poi.sports_complex" + Road -> "road" + RoadArterial -> "road.arterial" + RoadHighway -> "road.highway" + RoadHighwayControlledAccess -> "road.controlled_access" + RoadLocal -> "road.local" + Transit -> "transit" + TransitLine -> "transit.line" + TransitStation -> "transit.station" + TransitStationAirport -> "transit.station.airport" + TransitStationBus -> "transit.station.bus" + TransitStationRail -> "transit.station.rail" + Water -> "water" + +instance ToHttpApiData Feature where + toUrlPiece = T.pack . show + +-- | Feature element +data Element + = AllElements + | Geometry + | GeometryFill + | GeometryStroke + | Labels + | LabelsIcon + | LabelsText + | LabelsTextFill + | LabelsTextStroke + deriving (Eq) + +instance Show Element where + show element = case element of + AllElements -> "all" + Geometry -> "geometry" + GeometryFill -> "geometry.fill" + GeometryStroke -> "geometry.stroke" + Labels -> "labels" + LabelsIcon -> "labels.icon" + LabelsText -> "labels.text" + LabelsTextFill -> "labels.text.fill" + LabelsTextStroke -> "labels.text.stroke" + +instance ToHttpApiData Element where + toUrlPiece = T.pack . show + +-- | Map style operation +data MapStyleOp + = StyleHue Word8 Word8 Word8 + | StyleLightness Double + | StyleSaturation Double + | StyleGamma Double + | StyleInvertLightness Bool + | StyleVisibility Visibility + | StyleColor Word8 Word8 Word8 + | StyleWeight Int + deriving (Eq, Show) + +instance ToHttpApiData MapStyleOp where + toUrlPiece mapStyleOp + | StyleHue r g b <- mapStyleOp + = T.pack $ "hue:0x" ++ hexString r ++ hexString g ++ hexString b + | StyleLightness l <- mapStyleOp + = T.concat ["lightness:", toUrlPiece l] + | StyleSaturation s <- mapStyleOp + = T.concat ["saturation:", toUrlPiece s] + | StyleGamma g <- mapStyleOp + = T.concat ["gamma:", toUrlPiece g] + | StyleInvertLightness i <- mapStyleOp + = T.concat ["invert_lightness:", toUrlPiece i] + | StyleVisibility e <- mapStyleOp + = T.concat ["visibility:", toUrlPiece e] + | StyleColor r g b <- mapStyleOp + = T.pack $ "color:0x" ++ hexString r ++ hexString g ++ hexString b + | StyleWeight w <- mapStyleOp + = T.concat ["weight:", toUrlPiece w] + +instance ToHttpApiData [MapStyleOp] where + toUrlPiece ops = T.concat $ intersperse pipe $ map toUrlPiece ops + where + pipe = toUrlPiece ("|" :: Text) + +-- | Visibility +data Visibility + = On + | Off + | Simplified -- ^ Removes some, not all, style features + deriving (Eq) + +instance Show Visibility where + show visibility = case visibility of + On -> "on" + Off -> "off" + Simplified -> "simplified" + +instance ToHttpApiData Visibility where + toUrlPiece = T.pack . show + +-- | Markers +data Markers = Markers (Maybe MarkerStyle) [Location] + deriving (Eq, Show) + +instance ToHttpApiData Markers where + toUrlPiece (Markers markerStyleOpt ls) + | Nothing <- markerStyleOpt + = toUrlPiece ls + | Just (MarkerStyle Nothing Nothing Nothing) <- markerStyleOpt + = toUrlPiece ls + | Just markerStyle <- markerStyleOpt + = case ls of + [] -> toUrlPiece markerStyle + _ -> T.concat [toUrlPiece markerStyle, "|", toUrlPiece ls] + +-- | Marker style +data MarkerStyle = MarkerStyle + { markerSize :: Maybe MarkerSize + , markerColor :: Maybe MarkerColor + , markerLabel :: Maybe MarkerLabel + } deriving (Eq, Show) + +instance ToHttpApiData MarkerStyle where + toUrlPiece (MarkerStyle ms mc ml) = + T.concat $ intersperse pipe opts + where + pipe = toUrlPiece ("|" :: Text) + sizeUrl = T.append "size:" . toUrlPiece <$> ms + colorUrl = T.append "color:" . toUrlPiece <$> mc + labelUrl = T.append "label:" . toUrlPiece <$> ml + opts = catMaybes [sizeUrl, colorUrl, labelUrl] + +-- | Marker size +data MarkerSize + = Tiny + | Mid + | Small + deriving (Eq, Show) + +instance ToHttpApiData MarkerSize where + toUrlPiece markerSize' = case markerSize' of + Tiny -> "tiny" + Mid -> "mid" + Small -> "small" + +-- | Marker colour +data MarkerColor + = MarkerColor Word8 Word8 Word8 + | StdMarkerColor StdColor + deriving (Eq) + +instance Show MarkerColor where + show (MarkerColor r g b) = "0x" ++ hexString r ++ hexString g ++ hexString b + show (StdMarkerColor stdColor) = show stdColor + +instance ToHttpApiData MarkerColor where + toUrlPiece colour = T.pack $ show colour + +-- | Standard colours +data StdColor + = Black + | Brown + | Green + | Purple + | Yellow + | Blue + | Gray + | Orange + | Red + | White + deriving (Eq) + +instance Show StdColor where + show stdColor = case stdColor of + Black -> "black" + Brown -> "brown" + Green -> "green" + Purple -> "purple" + Yellow -> "yellow" + Blue -> "blue" + Gray -> "gray" + Orange -> "orange" + Red -> "red" + White -> "white" + +-- | Marker label character +newtype MarkerLabel = MarkerLabel Char + deriving (Eq, Show, ToHttpApiData) + +-- | Path +data Path = Path (Maybe PathStyle) [Location] + deriving (Eq, Show) + +instance ToHttpApiData Path where + toUrlPiece (Path pathStyleOpt ls) + | Nothing <- pathStyleOpt + = toUrlPiece ls + | Just (PathStyle Nothing Nothing Nothing Nothing) <- pathStyleOpt + = toUrlPiece ls + | Just pathStyle <- pathStyleOpt + = case ls of + [] -> toUrlPiece pathStyle + _ -> T.concat [toUrlPiece pathStyle, "|", toUrlPiece ls] + +-- | Path style: a geodesic path follows the curvature of the Earth. +data PathStyle = PathStyle + { pathWeight :: Maybe PathWeight -- ^ The default value is 5. + , pathColor :: Maybe PathColor + , pathFillColor :: Maybe PathColor + , pathGeodesic :: Maybe PathGeodesic -- ^ The default value is false. + } deriving (Eq, Show) + +instance ToHttpApiData PathStyle where + toUrlPiece (PathStyle mw mc mfc mg) = + T.concat $ intersperse pipe opts + where + pipe = toUrlPiece ("|" :: Text) + weightUrl = T.append "weight:" . toUrlPiece <$> mw + colorUrl = T.append "color:" . toUrlPiece <$> mc + fillColorUrl = T.append "fillcolor:" . toUrlPiece <$> mfc + geodesicUrl = T.append "geodesic:" . toUrlPiece <$> mg + opts = catMaybes [weightUrl, colorUrl, fillColorUrl, + geodesicUrl] + +-- | Path weight: in pixels. +newtype PathWeight = PathWeight Int + deriving (Eq, Show, ToHttpApiData) + +-- | Path colour +data PathColor + = PathColor Word8 Word8 Word8 + | PathColorAlpha Word8 Word8 Word8 Word8 + | StdPathColor StdColor + deriving (Eq) + +instance Show PathColor where + show (PathColor r g b) = "0x" ++ hexString r ++ hexString g ++ hexString b + show (PathColorAlpha r g b a) = "0x" ++ hexString r ++ hexString g ++ + hexString b ++ hexString a + show (StdPathColor stdColor) = show stdColor + +instance ToHttpApiData PathColor where + toUrlPiece colour = T.pack $ show colour + +-- | Path is geodesic +newtype PathGeodesic = PathGeodesic Bool + deriving (Eq, Show, ToHttpApiData) + +-- | Visible locations +newtype Visible = Visible [Location] + deriving (Eq, Show, ToHttpApiData) + +-- | Google Static Maps API +type GoogleStaticMapsAPI + = QueryParam "key" Key + :> QueryParam "center" Center + :> QueryParam "zoom" Zoom + :> QueryParam "size" Size + :> QueryParam "scale" Scale + :> QueryParam "format" Format + :> QueryParams "style" MapStyle + :> QueryParam "maptype" MapType + :> QueryParams "markers" Markers + :> QueryParams "path" Path + :> QueryParam "visible" Visible + :> Get '[PNG] StaticmapResponse + +-- | StaticmapResponse +type StaticmapResponse = DynamicImage + +-- | API type +api :: Proxy GoogleStaticMapsAPI +api = Proxy + +staticmap' + :: Maybe Key + -> Maybe Center + -> Maybe Zoom + -> Maybe Size + -> Maybe Scale + -> Maybe Format + -> [MapStyle] + -> Maybe MapType + -> [Markers] + -> [Path] + -> Maybe Visible + -> ClientM StaticmapResponse +staticmap' = client api + +googleApis :: BaseUrl +googleApis = BaseUrl Https "maps.googleapis.com" 443 "/maps/api/staticmap" + +-- | Retrieve a static map. NB: The use of the Google Static Maps API services +-- is subject to the <https://developers.google.com/maps/terms Google Maps APIs Terms of Service>. +staticmap + :: Manager + -> Key + -> Maybe Center + -> Maybe Zoom + -> Size + -> Maybe Scale + -> Maybe Format + -> [MapStyle] + -> Maybe MapType + -> [Markers] + -> [Path] + -> Maybe Visible + -> IO (Either ServantError StaticmapResponse) +staticmap + mgr + key + centerOpt + zoomOpt + size + scaleOpt + formatOpt + mapStyles + mapTypeOpt + markerss + paths + visibleOpt + = runClientM (staticmap' (Just key) centerOpt zoomOpt (Just size) + scaleOpt formatOpt mapStyles mapTypeOpt markerss paths visibleOpt) + (ClientEnv mgr googleApis)