diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,14 @@ +# 0.6.0.0 + +* Update documentation to reflect changes to Google Maps Platform + +* Rename module `Web.Google.Static.Maps` as `Web.Google.Maps.Static` and + `GoogleStaticMapsAPI` as `GoogleMapsStaticAPI` + +* Update `Web.Google.Maps.Common.Language` data constructors + +* Update dependencies for GHC 8.6.2 and revisit upper bounds + # 0.5.0.3 * Update dependencies for GHC 8.6.1 diff --git a/google-static-maps.cabal b/google-static-maps.cabal --- a/google-static-maps.cabal +++ b/google-static-maps.cabal @@ -1,13 +1,21 @@ name: google-static-maps -version: 0.5.0.3 -synopsis: Bindings to the Google Static Maps API -description: The +version: 0.6.0.0 +synopsis: Bindings to the Google Maps Static API (formerly Static + Maps API) +description: The + 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 , - which terms restrict the use of content. + NB: The use of the Google Maps Static API services is + subject to the + , + which terms restrict the use of content. End Users' use of + Google Maps is subject to the then-current Google + Maps/Google Earth Additional Terms of Service at + and Google + Privacy Policy at + . . This package has no connection with Google Inc. or its affiliates. @@ -24,21 +32,21 @@ library hs-source-dirs: src - exposed-modules: Web.Google.Static.Maps + exposed-modules: Web.Google.Maps.Static , Web.Google.Maps.Common build-depends: base >= 4.8 && < 4.13 - , base64-bytestring >= 0.1.1 && < 1.1 - , bytestring >= 0.10 && < 0.11 , aeson >= 0.7 && < 1.5 + , base64-bytestring >= 0.1.1 && < 1.1 , bytedump >= 0.9 && < 1.1 + , bytestring >= 0.10 && < 0.11 , cryptonite >= 0.1 && < 0.26 , double-conversion >= 0.2 && < 2.1 , http-client >= 0.2 && < 0.6 , JuicyPixels >= 1.0 && < 3.4 , memory >= 0.1 && < 0.15 , network-uri >= 2.6 && < 2.7 - , servant >= 0.14.1 && < 0.15 - , servant-client >= 0.11 && < 0.15 + , servant >= 0.14.1 && < 0.16 + , servant-client >= 0.11 && < 0.16 , servant-JuicyPixels >= 0.3 && < 0.4 , text >= 1.0 && < 1.3 , utf8-string >= 0.3 && < 1.1 diff --git a/src/Web/Google/Maps/Common.hs b/src/Web/Google/Maps/Common.hs --- a/src/Web/Google/Maps/Common.hs +++ b/src/Web/Google/Maps/Common.hs @@ -6,8 +6,8 @@ -- | -- Module : Web.Google.Maps.Common --- Description : Bindings to the Google Static Maps API --- Copyright : (c) Mike Pilgrem 2017 +-- Description : Common to the Google Maps Platform +-- Copyright : (c) Mike Pilgrem 2017, 2018 -- Maintainer : public@pilgrem.com -- Stability : experimental -- @@ -77,13 +77,16 @@ deriving (Eq, Show, ToHttpApiData) -- | Language: supported languages based on the list at --- (as at 13 March --- 2017). +-- (as at 29 December +-- 2018). data Language - = Arabic + = Albanian + | Arabic | Basque + | Belarusian | Bengali | Bulgarian + | Burmese | Catalan | ChineseSimplified | ChineseTraditional @@ -109,9 +112,12 @@ | Italian | Japanese | Kannada + | Kazakh | Korean + | Kyrgyz | Latvian | Lithuanian + | Macedonian | Malayalam | Marathi | Norwegian @@ -119,6 +125,7 @@ | Portuguese | PortugueseBrazil | PortuguesePortugal + | Punjabi | Romanian | Russian | Serbian @@ -132,15 +139,19 @@ | Thai | Turkish | Ukrainian + | Uzbek | Vietnamese deriving (Eq, Show) instance ToHttpApiData Language where toUrlPiece language = case language of + Albanian -> "sq" Arabic -> "ar" Basque -> "eu" + Belarusian -> "be" Bengali -> "bn" Bulgarian -> "bg" + Burmese -> "my" Catalan -> "ca" ChineseSimplified -> "zh-CN" ChineseTraditional -> "zh-TW" @@ -166,9 +177,12 @@ Italian -> "it" Japanese -> "ja" Kannada -> "kn" + Kazakh -> "kk" Korean -> "ko" + Kyrgyz -> "ky" Latvian -> "lv" Lithuanian -> "lt" + Macedonian -> "mk" Malayalam -> "ml" Marathi -> "mr" Norwegian -> "no" @@ -176,6 +190,7 @@ Portuguese -> "pt" PortugueseBrazil -> "pt-BR" PortuguesePortugal -> "pt-PT" + Punjabi -> "pa" Romanian -> "ro" Russian -> "ru" Serbian -> "sr" @@ -189,6 +204,7 @@ Thai -> "th" Turkish -> "tr" Ukrainian -> "uk" + Uzbek -> "uz" Vietnamese -> "vi" -- | Region: a ccTLD (country code top level domain). @@ -702,6 +718,6 @@ UK -> "uk" -- United Kingdom of Great Britain and Northern Ireland EU -> "eu" -- European Union --- | The base URL for the Google Maps APIs. +-- | The base URL for the Google Maps Platform APIs. googleMapsApis :: BaseUrl googleMapsApis = BaseUrl Https "maps.googleapis.com" 443 "/maps/api" diff --git a/src/Web/Google/Maps/Static.hs b/src/Web/Google/Maps/Static.hs new file mode 100644 --- /dev/null +++ b/src/Web/Google/Maps/Static.hs @@ -0,0 +1,675 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : Web.Google.Maps.Static +-- Description : Bindings to the Google Maps Static API (formerly Static Maps +-- API) +-- Copyright : (c) Mike Pilgrem 2017, 2018 +-- Maintainer : public@pilgrem.com +-- Stability : experimental +-- +-- This module has no connection with Google Inc. or its affiliates. +-- +-- The +-- returns a map as an image via an HTTP request. This library provides bindings +-- in Haskell to that API (version 2). +-- +-- NB: The use of the Google Maps Static API services is subject to the +-- , +-- which terms restrict the use of content. End Users' use of Google Maps is +-- subject to the then-current Google Maps/Google Earth Additional Terms of +-- Service at and Google Privacy +-- Policy at . +-- +-- The following are not yet implemented: non-PNG image formats; and encoded +-- polyline paths. +-- +-- The code below is an example console application to test the use of the +-- library with the Google Maps Static API. +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > module Main (main) where +-- > +-- > 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.Maps.Static (Center (..), Key (..), Location (..), Size (..), +-- > staticmap, StaticmapResponse (..), Zoom (..)) +-- > +-- > main :: IO () +-- > main = do +-- > putStrLn $ "A test of the Google Maps Static API.\nNB: The use of " ++ +-- > "the API services is subject to the Google Maps Platform Terms of " ++ +-- > "Serivce at https://cloud.google.com/maps-platform/terms/.\n" +-- > mgr <- newManager tlsManagerSettings +-- > let apiKey = Key "" +-- > -- If using a digital signature ... +-- > secret = Just $ Secret +-- > "" +-- > center = Just $ Center (Location 42.165950 (-71.362015)) +-- > zoom = Just $ Zoom 17 +-- > w = 400 +-- > h = 400 +-- > size = Size w h +-- > result <- staticmap mgr apiKey secret center zoom size Nothing Nothing +-- > [] Nothing Nothing Nothing [] [] Nothing +-- > case result of +-- > Right response -> do +-- > let picture = fromJust $ fromDynamicImage response +-- > title = "Test Google Maps Static API" +-- > window = InWindow title (w, h) (10, 10) +-- > display window white picture +-- > Left err -> putStrLn $ "Error! Result:\n" ++ show err +module Web.Google.Maps.Static + ( -- * Functions + staticmap + -- * API + , GoogleMapsStaticAPI + , api + -- * Types + , Key (..) + , Secret (..) + , Signature (..) + , Center (..) + , Location (..) + , LatLng (..) + , Address (..) + , Zoom (..) + , Size (..) + , Scale (..) + , Format (..) + , MapStyle (..) + , Feature (..) + , Element (..) + , MapStyleOp (..) + , Visibility (..) + , MapType (..) + , Language (..) + , Region (..) + , Markers (..) + , MarkerStyle (..) + , MarkerSize (..) + , MarkerColor (..) + , MarkerLabel (..) + , StdColor (..) + , URI (..) + , URIAuth (..) + , Anchor (..) + , StdAnchor (..) + , Path (..) + , PathStyle (..) + , PathWeight (..) + , PathColor (..) + , PathGeodesic (..) + , Visible (..) + , StaticmapResponse + ) where + +import Codec.Picture.Types (DynamicImage (..)) +import Crypto.Hash.Algorithms (SHA1) +import Crypto.MAC.HMAC (HMAC, hmac) +import Data.ByteArray (convert) +import Data.ByteString.Base64.URL (decode, encode) +import Data.ByteString.UTF8 as UTF8 (fromString) +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.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Word (Word8) +import Network.HTTP.Client (Manager) +import Network.URI (URI (..), URIAuth (..), uriToString) +import Servant.API ((:>), Get, QueryParam, QueryParams, safeLink, + ToHttpApiData (..)) +import Servant.Client (BaseUrl (..), client, ClientEnv (ClientEnv), ClientM, + runClientM, ServantError) +import Servant.JuicyPixels (PNG) +import Servant.Links (LinkArrayElementStyle (..), linkURI') +import Text.Bytedump (hexString) +import Web.Google.Maps.Common (Address (..), googleMapsApis, Key (..), + Language (..), LatLng (..), Location (..), Region (..)) + +-- | Secret for digital signature +newtype Secret = Secret Text + deriving (Eq, Show) + +-- | Signature +newtype Signature = Signature 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) + +-- | 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" + +-- | MapStyle +data MapStyle = MapStyle (Maybe Feature) (Maybe Element) [MapStyleOp] + deriving (Eq, Show) + +instance ToHttpApiData MapStyle where + toUrlPiece (MapStyle featureOpt elementOpt ops) = + T.concat $ intersperse "|" $ catMaybes [featureUrl, elementUrl] ++ + [opsUrl] + where + 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, Show) + +instance ToHttpApiData Feature where + toUrlPiece 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" + +-- | Feature element +data Element + = AllElements + | AllGeometry + | GeometryFill + | GeometryStroke + | AllLabels + | LabelsIcon + | LabelsText + | LabelsTextFill + | LabelsTextStroke + deriving (Eq, Show) + +instance ToHttpApiData Element where + toUrlPiece element = case element of + AllElements -> "all" + AllGeometry -> "geometry" + GeometryFill -> "geometry.fill" + GeometryStroke -> "geometry.stroke" + AllLabels -> "labels" + LabelsIcon -> "labels.icon" + LabelsText -> "labels.text" + LabelsTextFill -> "labels.text.fill" + LabelsTextStroke -> "labels.text.stroke" + +-- | 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 "|" $ map toUrlPiece ops + +-- | Visibility +data Visibility + = On + | Off + | Simplified -- ^ Removes some, not all, style features + deriving (Eq, Show) + +instance ToHttpApiData Visibility where + toUrlPiece visibility = case visibility of + On -> "on" + Off -> "off" + Simplified -> "simplified" + +-- | 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" + +-- | Markers +data Markers = Markers (Maybe MarkerStyle) [Location] + deriving (Eq, Show) + +instance ToHttpApiData Markers where + toUrlPiece (Markers markerStyleOpt ls) + | Nothing <- markerStyleOpt + = toUrlPiece ls + | Just (StdMarkerStyle Nothing Nothing Nothing) <- markerStyleOpt + = toUrlPiece ls + | Just markerStyle <- markerStyleOpt + = case ls of + [] -> toUrlPiece markerStyle + _ -> T.concat [toUrlPiece markerStyle, "|", toUrlPiece ls] + +-- | Marker style +data MarkerStyle + = StdMarkerStyle + { markerSize :: Maybe MarkerSize + , markerColor :: Maybe MarkerColor + , markerLabel :: Maybe MarkerLabel + } + | CustomIcon + { icon :: URI + , anchor :: Maybe Anchor + } + deriving (Eq, Show) + +instance ToHttpApiData MarkerStyle where + toUrlPiece markerStyle + | StdMarkerStyle ms mc ml <- markerStyle + = let size' = T.append "size:" . toUrlPiece <$> ms + color' = T.append "color:" . toUrlPiece <$> mc + label' = T.append "label:" . toUrlPiece <$> ml + opts = catMaybes [size', color', label'] + in T.concat $ intersperse "|" opts + | CustomIcon url ma <- markerStyle + = let icon' = T.concat ["icon:", toUrlPiece $ uriToString id url ""] + in case ma of + Nothing -> icon' + Just a -> T.concat [icon', "|", "anchor:", toUrlPiece a] + +-- | 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, Show) + +instance ToHttpApiData MarkerColor where + toUrlPiece (MarkerColor r g b) = T.pack $ "0x" ++ hexString r ++ hexString g + ++ hexString b + toUrlPiece (StdMarkerColor stdColor) = toUrlPiece stdColor + +-- | Standard colours +data StdColor + = Black + | Brown + | Green + | Purple + | Yellow + | Blue + | Gray + | Orange + | Red + | White + deriving (Eq, Show) + +instance ToHttpApiData StdColor where + toUrlPiece 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) + +-- | Anchor +data Anchor + = AnchorPoint Int Int + | StdAnchor StdAnchor + deriving (Eq, Show) + +instance ToHttpApiData Anchor where + toUrlPiece anchor' + | AnchorPoint x y <- anchor' + = T.pack (show x ++ "," ++ show y) + | StdAnchor stdAnchor <- anchor' + = toUrlPiece stdAnchor + +-- | Standard anchor points +data StdAnchor + = AnchorTop + | AnchorBottom + | AnchorLeft + | AnchorRight + | AnchorCenter + | AnchorTopLeft + | AnchorTopRight + | AnchorBottomLeft + | AnchorBottomRight + deriving (Eq, Show) + +instance ToHttpApiData StdAnchor where + toUrlPiece stdAnchor = case stdAnchor of + AnchorTop -> "top" + AnchorBottom -> "bottom" + AnchorLeft -> "left" + AnchorRight -> "right" + AnchorCenter -> "center" + AnchorTopLeft -> "topleft" + AnchorTopRight -> "topright" + AnchorBottomLeft -> "bottomleft" + AnchorBottomRight -> "bottomright" + +-- | 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 "|" opts + where + 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, Show) + +instance ToHttpApiData PathColor where + toUrlPiece (PathColor r g b) = T.pack $ "0x" ++ hexString r ++ hexString g + ++ hexString b + toUrlPiece (PathColorAlpha r g b a) = T.pack $ "0x" ++ hexString r ++ + hexString g ++ hexString b ++ hexString a + toUrlPiece (StdPathColor stdColor) = toUrlPiece stdColor + +-- | Path is geodesic +newtype PathGeodesic = PathGeodesic Bool + deriving (Eq, Show, ToHttpApiData) + +-- | Visible locations +newtype Visible = Visible [Location] + deriving (Eq, Show, ToHttpApiData) + +-- | Google Maps Static API +type GoogleMapsStaticAPI + = "staticmap" + :> QueryParam "key" Key + :> QueryParam "center" Center + :> QueryParam "zoom" Zoom + :> QueryParam "size" Size + :> QueryParam "scale" Scale + :> QueryParam "format" Format + :> QueryParams "style" MapStyle + :> QueryParam "maptype" MapType + :> QueryParam "language" Language + :> QueryParam "region" Region + :> QueryParams "markers" Markers + :> QueryParams "path" Path + :> QueryParam "visible" Visible + :> QueryParam "signature" Signature + :> Get '[PNG] StaticmapResponse + +-- | StaticmapResponse +type StaticmapResponse = DynamicImage + +-- | API type +api :: Proxy GoogleMapsStaticAPI +api = Proxy + +staticmap' + :: Maybe Key + -> Maybe Center + -> Maybe Zoom + -> Maybe Size + -> Maybe Scale + -> Maybe Format + -> [MapStyle] + -> Maybe MapType + -> Maybe Language + -> Maybe Region + -> [Markers] + -> [Path] + -> Maybe Visible + -> Maybe Signature + -> ClientM StaticmapResponse +staticmap' = client api + +-- | Retrieve a static map. NB: The use of the Google Maps Static API services +-- is subject to the +-- . +-- End Users' use of Google Maps is subject to the then-current Google +-- Maps/Google Earth Additional Terms of Service at +-- and Google Privacy Policy at +-- . +staticmap + :: Manager + -> Key + -> Maybe Secret + -> Maybe Center + -> Maybe Zoom + -> Size + -> Maybe Scale + -> Maybe Format + -> [MapStyle] + -> Maybe MapType + -> Maybe Language + -> Maybe Region + -> [Markers] + -> [Path] + -> Maybe Visible + -> IO (Either ServantError StaticmapResponse) +staticmap + mgr + key + secretOpt + centerOpt + zoomOpt + size + scaleOpt + formatOpt + mapStyles + mapTypeOpt + languageOpt + regionOpt + markerss + paths + visibleOpt + = case secretOpt of + Nothing -> runClientM (eval staticmap' Nothing) +-- CookieJar supported from servant-client-0.13 +#if MIN_VERSION_servant_client(0,13,0) + (ClientEnv mgr googleMapsApis Nothing) +#else + (ClientEnv mgr googleMapsApis) +#endif + Just secret -> do + let url = linkURI $ eval (safeLink api api) Nothing + signatureOpt = sign secret googleMapsApis url + runClientM (eval staticmap' signatureOpt) +-- CookieJar supported from servant-client-0.13 +#if MIN_VERSION_servant_client(0,13,0) + (ClientEnv mgr googleMapsApis Nothing) +#else + (ClientEnv mgr googleMapsApis) +#endif + where + linkURI = linkURI' LinkArrayElementPlain + eval f = f (Just key) centerOpt zoomOpt (Just size) scaleOpt formatOpt + mapStyles mapTypeOpt languageOpt regionOpt markerss paths + visibleOpt + +sign :: Secret -> BaseUrl -> URI -> Maybe Signature +sign (Secret secret) baseUrl url = do + secret' <- either (const Nothing) Just (decode $ encodeUtf8 secret) + let url' = UTF8.fromString $ baseUrlPath baseUrl ++ "/" ++ uriToString id url "" + signature = hmac secret' url' :: HMAC SHA1 + signature' = decodeUtf8 $ encode $ convert signature + return $ Signature signature' diff --git a/src/Web/Google/Static/Maps.hs b/src/Web/Google/Static/Maps.hs deleted file mode 100644 --- a/src/Web/Google/Static/Maps.hs +++ /dev/null @@ -1,666 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# 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, 2018 --- Maintainer : public@pilgrem.com --- Stability : experimental --- --- This module has no connection with Google Inc. or its affiliates. --- --- The --- returns a map as an image via an HTTP request. This library provides bindings --- in Haskell to that API (version 2). --- --- NB: The use of the Google Static Maps API services is subject to the --- , --- which terms restrict the use of content. --- --- The following are not yet implemented: non-PNG image formats; 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 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 "" --- > -- If using a digital signature ... --- > secret = Just $ Secret --- > "" --- > center = Just $ Center (Location 42.165950 (-71.362015)) --- > zoom = Just $ Zoom 17 --- > w = 400 --- > h = 400 --- > size = Size w h --- > result <- staticmap mgr apiKey secret center zoom size Nothing Nothing --- > [] 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 (..) - , Secret (..) - , Signature (..) - , Center (..) - , Location (..) - , LatLng (..) - , Address (..) - , Zoom (..) - , Size (..) - , Scale (..) - , Format (..) - , MapStyle (..) - , Feature (..) - , Element (..) - , MapStyleOp (..) - , Visibility (..) - , MapType (..) - , Language (..) - , Region (..) - , Markers (..) - , MarkerStyle (..) - , MarkerSize (..) - , MarkerColor (..) - , MarkerLabel (..) - , StdColor (..) - , URI (..) - , URIAuth (..) - , Anchor (..) - , StdAnchor (..) - , Path (..) - , PathStyle (..) - , PathWeight (..) - , PathColor (..) - , PathGeodesic (..) - , Visible (..) - , StaticmapResponse - ) where - -import Codec.Picture.Types (DynamicImage (..)) -import Crypto.Hash.Algorithms (SHA1) -import Crypto.MAC.HMAC (HMAC, hmac) -import Data.ByteArray (convert) -import Data.ByteString.Base64.URL (decode, encode) -import Data.ByteString.UTF8 as UTF8 (fromString) -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.Text.Encoding (decodeUtf8, encodeUtf8) -import Data.Word (Word8) -import Network.HTTP.Client (Manager) -import Network.URI (URI (..), URIAuth (..), uriToString) -import Servant.API ((:>), Get, QueryParam, QueryParams, safeLink, - ToHttpApiData (..)) -import Servant.Client (BaseUrl (..), client, ClientEnv (ClientEnv), ClientM, - runClientM, ServantError) -import Servant.JuicyPixels (PNG) -import Servant.Links (LinkArrayElementStyle (..), linkURI') -import Text.Bytedump (hexString) -import Web.Google.Maps.Common (Address (..), googleMapsApis, Key (..), - Language (..), LatLng (..), Location (..), Region (..)) - --- | Secret for digital signature -newtype Secret = Secret Text - deriving (Eq, Show) - --- | Signature -newtype Signature = Signature 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) - --- | 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" - --- | MapStyle -data MapStyle = MapStyle (Maybe Feature) (Maybe Element) [MapStyleOp] - deriving (Eq, Show) - -instance ToHttpApiData MapStyle where - toUrlPiece (MapStyle featureOpt elementOpt ops) = - T.concat $ intersperse "|" $ catMaybes [featureUrl, elementUrl] ++ - [opsUrl] - where - 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, Show) - -instance ToHttpApiData Feature where - toUrlPiece 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" - --- | Feature element -data Element - = AllElements - | AllGeometry - | GeometryFill - | GeometryStroke - | AllLabels - | LabelsIcon - | LabelsText - | LabelsTextFill - | LabelsTextStroke - deriving (Eq, Show) - -instance ToHttpApiData Element where - toUrlPiece element = case element of - AllElements -> "all" - AllGeometry -> "geometry" - GeometryFill -> "geometry.fill" - GeometryStroke -> "geometry.stroke" - AllLabels -> "labels" - LabelsIcon -> "labels.icon" - LabelsText -> "labels.text" - LabelsTextFill -> "labels.text.fill" - LabelsTextStroke -> "labels.text.stroke" - --- | 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 "|" $ map toUrlPiece ops - --- | Visibility -data Visibility - = On - | Off - | Simplified -- ^ Removes some, not all, style features - deriving (Eq, Show) - -instance ToHttpApiData Visibility where - toUrlPiece visibility = case visibility of - On -> "on" - Off -> "off" - Simplified -> "simplified" - --- | 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" - --- | Markers -data Markers = Markers (Maybe MarkerStyle) [Location] - deriving (Eq, Show) - -instance ToHttpApiData Markers where - toUrlPiece (Markers markerStyleOpt ls) - | Nothing <- markerStyleOpt - = toUrlPiece ls - | Just (StdMarkerStyle Nothing Nothing Nothing) <- markerStyleOpt - = toUrlPiece ls - | Just markerStyle <- markerStyleOpt - = case ls of - [] -> toUrlPiece markerStyle - _ -> T.concat [toUrlPiece markerStyle, "|", toUrlPiece ls] - --- | Marker style -data MarkerStyle - = StdMarkerStyle - { markerSize :: Maybe MarkerSize - , markerColor :: Maybe MarkerColor - , markerLabel :: Maybe MarkerLabel - } - | CustomIcon - { icon :: URI - , anchor :: Maybe Anchor - } - deriving (Eq, Show) - -instance ToHttpApiData MarkerStyle where - toUrlPiece markerStyle - | StdMarkerStyle ms mc ml <- markerStyle - = let size' = T.append "size:" . toUrlPiece <$> ms - color' = T.append "color:" . toUrlPiece <$> mc - label' = T.append "label:" . toUrlPiece <$> ml - opts = catMaybes [size', color', label'] - in T.concat $ intersperse "|" opts - | CustomIcon url ma <- markerStyle - = let icon' = T.concat ["icon:", toUrlPiece $ uriToString id url ""] - in case ma of - Nothing -> icon' - Just a -> T.concat [icon', "|", "anchor:", toUrlPiece a] - --- | 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, Show) - -instance ToHttpApiData MarkerColor where - toUrlPiece (MarkerColor r g b) = T.pack $ "0x" ++ hexString r ++ hexString g - ++ hexString b - toUrlPiece (StdMarkerColor stdColor) = toUrlPiece stdColor - --- | Standard colours -data StdColor - = Black - | Brown - | Green - | Purple - | Yellow - | Blue - | Gray - | Orange - | Red - | White - deriving (Eq, Show) - -instance ToHttpApiData StdColor where - toUrlPiece 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) - --- | Anchor -data Anchor - = AnchorPoint Int Int - | StdAnchor StdAnchor - deriving (Eq, Show) - -instance ToHttpApiData Anchor where - toUrlPiece anchor' - | AnchorPoint x y <- anchor' - = T.pack (show x ++ "," ++ show y) - | StdAnchor stdAnchor <- anchor' - = toUrlPiece stdAnchor - --- | Standard anchor points -data StdAnchor - = AnchorTop - | AnchorBottom - | AnchorLeft - | AnchorRight - | AnchorCenter - | AnchorTopLeft - | AnchorTopRight - | AnchorBottomLeft - | AnchorBottomRight - deriving (Eq, Show) - -instance ToHttpApiData StdAnchor where - toUrlPiece stdAnchor = case stdAnchor of - AnchorTop -> "top" - AnchorBottom -> "bottom" - AnchorLeft -> "left" - AnchorRight -> "right" - AnchorCenter -> "center" - AnchorTopLeft -> "topleft" - AnchorTopRight -> "topright" - AnchorBottomLeft -> "bottomleft" - AnchorBottomRight -> "bottomright" - --- | 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 "|" opts - where - 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, Show) - -instance ToHttpApiData PathColor where - toUrlPiece (PathColor r g b) = T.pack $ "0x" ++ hexString r ++ hexString g - ++ hexString b - toUrlPiece (PathColorAlpha r g b a) = T.pack $ "0x" ++ hexString r ++ - hexString g ++ hexString b ++ hexString a - toUrlPiece (StdPathColor stdColor) = toUrlPiece stdColor - --- | 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 - = "staticmap" - :> QueryParam "key" Key - :> QueryParam "center" Center - :> QueryParam "zoom" Zoom - :> QueryParam "size" Size - :> QueryParam "scale" Scale - :> QueryParam "format" Format - :> QueryParams "style" MapStyle - :> QueryParam "maptype" MapType - :> QueryParam "language" Language - :> QueryParam "region" Region - :> QueryParams "markers" Markers - :> QueryParams "path" Path - :> QueryParam "visible" Visible - :> QueryParam "signature" Signature - :> 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 - -> Maybe Language - -> Maybe Region - -> [Markers] - -> [Path] - -> Maybe Visible - -> Maybe Signature - -> ClientM StaticmapResponse -staticmap' = client api - --- | Retrieve a static map. NB: The use of the Google Static Maps API services --- is subject to the . -staticmap - :: Manager - -> Key - -> Maybe Secret - -> Maybe Center - -> Maybe Zoom - -> Size - -> Maybe Scale - -> Maybe Format - -> [MapStyle] - -> Maybe MapType - -> Maybe Language - -> Maybe Region - -> [Markers] - -> [Path] - -> Maybe Visible - -> IO (Either ServantError StaticmapResponse) -staticmap - mgr - key - secretOpt - centerOpt - zoomOpt - size - scaleOpt - formatOpt - mapStyles - mapTypeOpt - languageOpt - regionOpt - markerss - paths - visibleOpt - = case secretOpt of - Nothing -> runClientM (eval staticmap' Nothing) --- CookieJar supported from servant-client-0.13 -#if MIN_VERSION_servant_client(0,13,0) - (ClientEnv mgr googleMapsApis Nothing) -#else - (ClientEnv mgr googleMapsApis) -#endif - Just secret -> do - let url = linkURI $ eval (safeLink api api) Nothing - signatureOpt = sign secret googleMapsApis url - runClientM (eval staticmap' signatureOpt) --- CookieJar supported from servant-client-0.13 -#if MIN_VERSION_servant_client(0,13,0) - (ClientEnv mgr googleMapsApis Nothing) -#else - (ClientEnv mgr googleMapsApis) -#endif - where - linkURI = linkURI' LinkArrayElementPlain - eval f = f (Just key) centerOpt zoomOpt (Just size) scaleOpt formatOpt - mapStyles mapTypeOpt languageOpt regionOpt markerss paths - visibleOpt - -sign :: Secret -> BaseUrl -> URI -> Maybe Signature -sign (Secret secret) baseUrl url = do - secret' <- either (const Nothing) Just (decode $ encodeUtf8 secret) - let url' = UTF8.fromString $ baseUrlPath baseUrl ++ "/" ++ uriToString id url "" - signature = hmac secret' url' :: HMAC SHA1 - signature' = decodeUtf8 $ encode $ convert signature - return $ Signature signature'