diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,9 @@ +# 0.4.0.0 + +* Implement `language` and `region` parameters + +* Implement digital signatures + # 0.3.0.0 * Fix bug in instance of `ToHttpApiData` for `Location` @@ -10,7 +16,7 @@ # 0.2.0.0 -* Implementation of `signature` and custom marker icons +* Implement `signature` and custom marker icons * Move `staticmap` from the end of the base URL to the start of the API type diff --git a/google-static-maps.cabal b/google-static-maps.cabal --- a/google-static-maps.cabal +++ b/google-static-maps.cabal @@ -1,44 +1,50 @@ -name: google-static-maps -version: 0.3.0.0 -synopsis: Bindings to the Google 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. - . - 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 -extra-source-files: changelog.md -cabal-version: >=1.10 - -library - hs-source-dirs: src - exposed-modules: Web.Google.Static.Maps - , Web.Google.Maps.Common - build-depends: base >= 4.7 && < 5 - , aeson >= 1.0 && < 1.1 - , bytedump >= 1.0 && < 1.1 - , double-conversion >= 2.0 && < 2.1 - , http-client >= 0.5 && < 0.6 - , JuicyPixels >= 3.2 && < 3.3 - , network-uri >= 2.6 && < 2.7 - , 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 +name: google-static-maps +version: 0.4.0.0 +synopsis: Bindings to the Google 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. + . + 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 +extra-source-files: changelog.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Web.Google.Static.Maps + , Web.Google.Maps.Common + build-depends: base >= 4.7 && < 5 + , base64-bytestring >= 1.0 && < 1.1 + , bytestring >= 0.10 && < 0.11 + , aeson >= 1.0 && < 1.1 + , bytedump >= 1.0 && < 1.1 + , cryptonite >= 0.21 && < 0.22 + , double-conversion >= 2.0 && < 2.1 + , http-client >= 0.5 && < 0.6 + , JuicyPixels >= 3.2 && < 3.3 + , memory >= 0.14 && < 0.15 + , MissingH >=1.4 && < 1.5 + , network-uri >= 2.6 && < 2.7 + , servant >= 0.9 && < 0.10 + , servant-client >= 0.9 && < 0.10 + , servant-JuicyPixels >= 0.3 && < 0.4 + , text >= 1.2 && < 1.3 + , utf8-string >= 1.0 && < 1.1 + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/mpilgrem/google-static-maps 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 @@ -1,6 +1,7 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -- | @@ -15,43 +16,692 @@ ( -- * Functions googleMapsApis -- * Types + , Address (..) , Key (..) + , Language (..) + , LatLng (..) , Location (..) + , Region (..) ) where import Data.Aeson (FromJSON) import Data.Double.Conversion.Text (toFixed) -import Data.List (intersperse) +import Data.Either (Either (..)) +import Data.Eq (Eq) +import Data.Function (($)) +import Data.List (intersperse, map) import Data.Text (Text) import qualified Data.Text as T (concat) +import GHC.Exts (Double) import GHC.Generics (Generic) import Servant.API (ToHttpApiData (..)) import Servant.Client (BaseUrl (..), Scheme (..)) +import Text.Show (Show) -- | API key newtype Key = Key Text deriving (Eq, Show, ToHttpApiData) --- | Location: precision in latitude or longitude beyond 6 decimal places is --- ignored. -data Location = Location +-- | Location +data Location + = Coords LatLng + | Locale Address + deriving (Eq, Show) + +instance ToHttpApiData Location where + toUrlPiece location + | Coords latlng <- location + = toUrlPiece latlng + | Locale address <- location + = toUrlPiece address + +instance ToHttpApiData [Location] where + toUrlPiece [] = "" + toUrlPiece ls = T.concat $ intersperse "|" $ map toUrlPiece ls + +-- | Latitude and longitude: precision beyond 6 decimal places is ignored. +data LatLng = LatLng { lat :: Double -- ^ Takes any value between -90 and 90. , lng :: Double -- ^ Takes any value between -180 and 180. } deriving (Eq, Show, Generic) -instance ToHttpApiData Location where - toUrlPiece (Location lat' lng') = T.concat [toFixed precision lat', ",", - toFixed precision lng'] +instance ToHttpApiData LatLng where + toUrlPiece (LatLng lat' lng') + = T.concat [toFixed precision lat', ",", toFixed precision lng'] where precision = 6 -- Precision beyond 6 decimal places is ignored. -instance ToHttpApiData [Location] where - toUrlPiece [] = "" - toUrlPiece ls = T.concat $ intersperse pipe $ map toUrlPiece ls - where - pipe = toUrlPiece ("|" :: Text) +instance FromJSON LatLng -instance FromJSON Location +-- | Address +newtype Address = Address Text + deriving (Eq, Show, ToHttpApiData) + +-- | Language: supported languages based on the list at +-- (as at 13 March +-- 2017). +data Language + = Arabic + | Basque + | Bengali + | Bulgarian + | Catalan + | ChineseSimplified + | ChineseTraditional + | Croatian + | Czech + | Danish + | Dutch + | German + | Greek + | English + | EnglishAustralian + | EnglishBritish + | Farsi + | Filipino + | Finnish + | French + | Galician + | Gujarati + | Hebrew + | Hindi + | Hungarian + | Indonesian + | Italian + | Japanese + | Kannada + | Korean + | Latvian + | Lithuanian + | Malayalam + | Marathi + | Norwegian + | Polish + | Portuguese + | PortugueseBrazil + | PortuguesePortugal + | Romanian + | Russian + | Serbian + | Slovak + | Slovenian + | Spanish + | Swedish + | Tagalog + | Tamil + | Telugu + | Thai + | Turkish + | Ukrainian + | Vietnamese + deriving (Eq, Show) + +instance ToHttpApiData Language where + toUrlPiece language = case language of + Arabic -> "ar" + Basque -> "eu" + Bengali -> "bn" + Bulgarian -> "bg" + Catalan -> "ca" + ChineseSimplified -> "zh-CN" + ChineseTraditional -> "zh-TW" + Croatian -> "hr" + Czech -> "cs" + Danish -> "da" + Dutch -> "nl" + German -> "de" + Greek -> "el" + English -> "en" + EnglishAustralian -> "en-AU" + EnglishBritish -> "en-GB" + Farsi -> "fa" + Filipino -> "fil" + Finnish -> "fi" + French -> "fr" + Galician -> "gl" + Gujarati -> "gu" + Hebrew -> "iw" + Hindi -> "hi" + Hungarian -> "hu" + Indonesian -> "id" + Italian -> "it" + Japanese -> "ja" + Kannada -> "kn" + Korean -> "ko" + Latvian -> "lv" + Lithuanian -> "lt" + Malayalam -> "ml" + Marathi -> "mr" + Norwegian -> "no" + Polish -> "pl" + Portuguese -> "pt" + PortugueseBrazil -> "pt-BR" + PortuguesePortugal -> "pt-PT" + Romanian -> "ro" + Russian -> "ru" + Serbian -> "sr" + Slovak -> "sk" + Slovenian -> "sl" + Spanish -> "es" + Swedish -> "sv" + Tagalog -> "tl" + Tamil -> "ta" + Telugu -> "te" + Thai -> "th" + Turkish -> "tr" + Ukrainian -> "uk" + Vietnamese -> "vi" + +-- | Region: a ccTLD (country code top level domain). +data Region + = AD + | AE + | AF + | AG + | AI + | AL + | AM + | AO + | AQ + | AR + | AS + | AT + | AU + | AW + | AX + | AZ + | BA + | BB + | BD + | BE + | BF + | BG + | BH + | BI + | BJ + | BL + | BM + | BN + | BO + | BQ + | BR + | BS + | BT + | BV + | BW + | BY + | BZ + | CA + | CC + | CD + | CF + | CG + | CH + | CI + | CK + | CL + | CM + | CN + | CO + | CR + | CU + | CV + | CW + | CX + | CY + | CZ + | DE + | DJ + | DK + | DM + | DO + | DZ + | EC + | EE + | EG + | EH + | ER + | ES + | ET + | FI + | FJ + | FK + | FM + | FO + | FR + | GA + | GB + | GD + | GE + | GF + | GG + | GH + | GI + | GL + | GM + | GN + | GP + | GQ + | GR + | GS + | GT + | GU + | GW + | GY + | HK + | HM + | HN + | HR + | HT + | HU + | ID + | IE + | IL + | IM + | IN + | IO + | IQ + | IR + | IS + | IT + | JE + | JM + | JO + | JP + | KE + | KG + | KH + | KI + | KM + | KN + | KP + | KR + | KW + | KY + | KZ + | LA + | LB + | LC + | LI + | LK + | LR + | LS + | LT + | LU + | LV + | LY + | MA + | MC + | MD + | ME + | MF + | MG + | MH + | MK + | ML + | MM + | MN + | MO + | MP + | MQ + | MR + | MS + | MT + | MU + | MV + | MW + | MX + | MY + | MZ + | NA + | NC + | NE + | NF + | NG + | NI + | NL + | NO + | NP + | NR + | NU + | NZ + | OM + | PA + | PE + | PF + | PG + | PH + | PK + | PL + | PM + | PN + | PR + | PS + | PT + | PW + | PY + | QA + | RE + | RO + | RS + | RU + | RW + | SA + | SB + | SC + | SD + | SE + | SG + | SH + | SI + | SJ + | SK + | SL + | SM + | SN + | SO + | SR + | SS + | ST + | SV + | SX + | SY + | SZ + | TC + | TD + | TF + | TG + | TH + | TJ + | TK + | TL + | TM + | TN + | TO + | TR + | TT + | TV + | TW + | TZ + | UA + | UG + | UM + | US + | UY + | UZ + | VA + | VC + | VE + | VG + | VI + | VN + | VU + | WF + | WS + | YE + | YT + | ZA + | ZM + | ZW + | AC -- Saint Helena, Ascension and Tristan da Cunha + | UK -- United Kingdom of Great Britain and Northern Ireland + | EU -- European Union + deriving (Eq, Show) + +instance ToHttpApiData Region where + toUrlPiece region = case region of + AD -> "ad" + AE -> "ae" + AF -> "af" + AG -> "ag" + AI -> "ai" + AL -> "al" + AM -> "am" + AO -> "ao" + AQ -> "aq" + AR -> "ar" + AS -> "as" + AT -> "at" + AU -> "au" + AW -> "aw" + AX -> "ax" + AZ -> "az" + BA -> "ba" + BB -> "bb" + BD -> "bd" + BE -> "be" + BF -> "bf" + BG -> "bg" + BH -> "bh" + BI -> "bi" + BJ -> "bj" + BL -> "bl" + BM -> "bm" + BN -> "bn" + BO -> "bo" + BQ -> "bq" + BR -> "br" + BS -> "bs" + BT -> "bt" + BV -> "bv" + BW -> "bw" + BY -> "by" + BZ -> "bz" + CA -> "ca" + CC -> "cc" + CD -> "cd" + CF -> "cf" + CG -> "cg" + CH -> "ch" + CI -> "ci" + CK -> "ck" + CL -> "cl" + CM -> "cm" + CN -> "cn" + CO -> "co" + CR -> "cr" + CU -> "cu" + CV -> "cv" + CW -> "cw" + CX -> "cx" + CY -> "cy" + CZ -> "cz" + DE -> "de" + DJ -> "dj" + DK -> "dk" + DM -> "dm" + DO -> "do" + DZ -> "dz" + EC -> "ec" + EE -> "ee" + EG -> "eg" + EH -> "eh" + ER -> "er" + ES -> "es" + ET -> "et" + FI -> "fi" + FJ -> "fj" + FK -> "fk" + FM -> "fm" + FO -> "fo" + FR -> "fr" + GA -> "ga" + GB -> "gb" + GD -> "gd" + GE -> "ge" + GF -> "gf" + GG -> "gg" + GH -> "gh" + GI -> "gi" + GL -> "gl" + GM -> "gm" + GN -> "gn" + GP -> "gp" + GQ -> "gq" + GR -> "gr" + GS -> "gs" + GT -> "gt" + GU -> "gu" + GW -> "gw" + GY -> "gy" + HK -> "hk" + HM -> "hm" + HN -> "hn" + HR -> "hr" + HT -> "ht" + HU -> "hu" + ID -> "id" + IE -> "ie" + IL -> "il" + IM -> "im" + IN -> "in" + IO -> "io" + IQ -> "iq" + IR -> "ir" + IS -> "is" + IT -> "it" + JE -> "je" + JM -> "jm" + JO -> "jo" + JP -> "jp" + KE -> "ke" + KG -> "kg" + KH -> "kh" + KI -> "ki" + KM -> "km" + KN -> "kn" + KP -> "kp" + KR -> "kr" + KW -> "kw" + KY -> "ky" + KZ -> "kz" + LA -> "la" + LB -> "lb" + LC -> "lc" + LI -> "li" + LK -> "lk" + LR -> "lr" + LS -> "ls" + LT -> "lt" + LU -> "lu" + LV -> "lv" + LY -> "ly" + MA -> "ma" + MC -> "mc" + MD -> "md" + ME -> "me" + MF -> "mf" + MG -> "mg" + MH -> "mh" + MK -> "mk" + ML -> "ml" + MM -> "mm" + MN -> "mn" + MO -> "mo" + MP -> "mp" + MQ -> "mq" + MR -> "mr" + MS -> "ms" + MT -> "mt" + MU -> "mu" + MV -> "mv" + MW -> "mw" + MX -> "mx" + MY -> "my" + MZ -> "mz" + NA -> "na" + NC -> "nc" + NE -> "ne" + NF -> "nf" + NG -> "ng" + NI -> "ni" + NL -> "nl" + NO -> "no" + NP -> "np" + NR -> "nr" + NU -> "nu" + NZ -> "nz" + OM -> "om" + PA -> "pa" + PE -> "pe" + PF -> "pf" + PG -> "pg" + PH -> "ph" + PK -> "pk" + PL -> "pl" + PM -> "pm" + PN -> "pn" + PR -> "pr" + PS -> "ps" + PT -> "pt" + PW -> "pw" + PY -> "py" + QA -> "qa" + RE -> "re" + RO -> "ro" + RS -> "rs" + RU -> "ru" + RW -> "rw" + SA -> "sa" + SB -> "sb" + SC -> "sc" + SD -> "sd" + SE -> "se" + SG -> "sg" + SH -> "sh" + SI -> "si" + SJ -> "sj" + SK -> "sk" + SL -> "sl" + SM -> "sm" + SN -> "sn" + SO -> "so" + SR -> "sr" + SS -> "ss" + ST -> "st" + SV -> "sv" + SX -> "sx" + SY -> "sy" + SZ -> "sz" + TC -> "tc" + TD -> "td" + TF -> "tf" + TG -> "tg" + TH -> "th" + TJ -> "tj" + TK -> "tk" + TL -> "tl" + TM -> "tm" + TN -> "tn" + TO -> "to" + TR -> "tr" + TT -> "tt" + TV -> "tv" + TW -> "tw" + TZ -> "tz" + UA -> "ua" + UG -> "ug" + UM -> "um" + US -> "us" + UY -> "uy" + UZ -> "uz" + VA -> "va" + VC -> "vc" + VE -> "ve" + VG -> "vg" + VI -> "vi" + VN -> "vn" + VU -> "vu" + WF -> "wf" + WS -> "ws" + YE -> "ye" + YT -> "yt" + ZA -> "za" + ZM -> "zm" + ZW -> "zw" + AC -> "ac" -- Saint Helena, Ascension and Tristan da Cunha + UK -> "uk" -- United Kingdom of Great Britain and Northern Ireland + EU -> "eu" -- European Union -- | The base URL for the Google Maps APIs. googleMapsApis :: BaseUrl diff --git a/src/Web/Google/Static/Maps.hs b/src/Web/Google/Static/Maps.hs --- a/src/Web/Google/Static/Maps.hs +++ b/src/Web/Google/Static/Maps.hs @@ -21,9 +21,8 @@ -- , -- which terms restrict the use of content. -- --- The following are not yet implemented: certain optional parameters --- ('language', and 'region'); address locations; non-PNG image --- formats; and encoded polyline paths. +-- 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. @@ -47,13 +46,15 @@ -- > \at https://developers.google.com/maps/terms.\n" -- > mgr <- newManager tlsManagerSettings -- > let apiKey = Key "" +-- > secret = Just $ Secret " \URL_SIGNING_SECRET>" -- If using a digital signature -- > center = Just $ Center (Location 42.165950 (-71.362015)) -- > zoom = Just $ Zoom 17 -- > w = 400 -- > h = 400 -- > size = Size w h --- > result <- staticmap mgr apiKey Nothing center zoom size Nothing Nothing --- > [] Nothing [] [] Nothing +-- > 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 @@ -69,19 +70,24 @@ , api -- * Types , Key (..) + , Secret (..) , Signature (..) , Center (..) , Location (..) + , LatLng (..) + , Address (..) , Zoom (..) , Size (..) , Scale (..) , Format (..) - , MapType (..) , MapStyle (..) , Feature (..) , Element (..) , MapStyleOp (..) , Visibility (..) + , MapType (..) + , Language (..) + , Region (..) , Markers (..) , MarkerStyle (..) , MarkerSize (..) @@ -102,21 +108,37 @@ ) where import Codec.Picture.Types (DynamicImage (..)) +import Crypto.Hash.Algorithms (SHA1) +import Crypto.MAC.HMAC (HMAC, hmac) +import Data.ByteArray (convert) +import qualified Data.ByteString as B (pack, unpack) +import Data.ByteString.Base64.URL (decode, encode) +import qualified Data.ByteString.Lazy as L (unpack) +import Data.ByteString.Builder (stringUtf8, toLazyByteString) +import Data.ByteString.UTF8 as UTF8 (fromString) import Data.List (intersperse) import Data.Maybe (catMaybes) import Data.Proxy (Proxy (..)) +import Data.String.Utils (replace) import Data.Text (Text) import qualified Data.Text as T (append, concat, pack) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Word (Word8) +import Debug.Trace (trace) import Network.HTTP.Client (Manager) import Network.URI (URI (..), URIAuth (..), uriToString) -import Servant.API ((:>), Get, QueryParam, QueryParams, ToHttpApiData (..)) -import Servant.Client (client, ClientEnv (..), ClientM, runClientM, - ServantError) +import Servant.API ((:>), Get, QueryParam, QueryParams, safeLink, + ToHttpApiData (..)) +import Servant.Client (BaseUrl (..), client, ClientEnv (..), ClientM, + runClientM, ServantError) import Servant.JuicyPixels (PNG) import Text.Bytedump (hexString) +import Web.Google.Maps.Common (Address (..), googleMapsApis, Key (..), + Language (..), LatLng (..), Location (..), Region (..)) -import Web.Google.Maps.Common (googleMapsApis, Key (..), Location (..)) +-- | Secret for digital signature +newtype Secret = Secret Text + deriving (Eq, Show) -- | Signature newtype Signature = Signature Text @@ -166,31 +188,15 @@ 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] ++ + T.concat $ intersperse "|" $ catMaybes [featureUrl, elementUrl] ++ [opsUrl] where - pipe = toUrlPiece ("|" :: Text) featureUrl = T.append "feature:" . toUrlPiece <$> featureOpt elementUrl = T.append "element:" . toUrlPiece <$> elementOpt opsUrl = toUrlPiece ops @@ -325,9 +331,7 @@ = T.concat ["weight:", toUrlPiece w] instance ToHttpApiData [MapStyleOp] where - toUrlPiece ops = T.concat $ intersperse pipe $ map toUrlPiece ops - where - pipe = toUrlPiece ("|" :: Text) + toUrlPiece ops = T.concat $ intersperse "|" $ map toUrlPiece ops -- | Visibility data Visibility @@ -342,6 +346,21 @@ 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) @@ -377,14 +396,12 @@ color' = T.append "color:" . toUrlPiece <$> mc label' = T.append "label:" . toUrlPiece <$> ml opts = catMaybes [size', color', label'] - in T.concat $ intersperse pipe opts + 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', pipe, "anchor:", toUrlPiece a] - where - pipe = toUrlPiece ("|" :: Text) + Just a -> T.concat [icon', "|", "anchor:", toUrlPiece a] -- | Marker size data MarkerSize @@ -504,9 +521,8 @@ instance ToHttpApiData PathStyle where toUrlPiece (PathStyle mw mc mfc mg) = - T.concat $ intersperse pipe opts + T.concat $ intersperse "|" opts where - pipe = toUrlPiece ("|" :: Text) weightUrl = T.append "weight:" . toUrlPiece <$> mw colorUrl = T.append "color:" . toUrlPiece <$> mc fillColorUrl = T.append "fillcolor:" . toUrlPiece <$> mfc @@ -543,18 +559,20 @@ -- | Google Static Maps API type GoogleStaticMapsAPI = "staticmap" - :> QueryParam "key" Key - :> QueryParam "signature" Signature - :> 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 + :> 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 @@ -566,7 +584,6 @@ staticmap' :: Maybe Key - -> Maybe Signature -> Maybe Center -> Maybe Zoom -> Maybe Size @@ -574,9 +591,12 @@ -> Maybe Format -> [MapStyle] -> Maybe MapType + -> Maybe Language + -> Maybe Region -> [Markers] -> [Path] -> Maybe Visible + -> Maybe Signature -> ClientM StaticmapResponse staticmap' = client api @@ -585,7 +605,7 @@ staticmap :: Manager -> Key - -> Maybe Signature + -> Maybe Secret -> Maybe Center -> Maybe Zoom -> Size @@ -593,6 +613,8 @@ -> Maybe Format -> [MapStyle] -> Maybe MapType + -> Maybe Language + -> Maybe Region -> [Markers] -> [Path] -> Maybe Visible @@ -600,7 +622,7 @@ staticmap mgr key - signatureOpt + secretOpt centerOpt zoomOpt size @@ -608,10 +630,41 @@ formatOpt mapStyles mapTypeOpt + languageOpt + regionOpt markerss paths visibleOpt - = runClientM (staticmap' (Just key) signatureOpt centerOpt zoomOpt - (Just size) scaleOpt formatOpt mapStyles mapTypeOpt markerss paths - visibleOpt) - (ClientEnv mgr googleMapsApis) + = case secretOpt of + Nothing -> runClientM (eval staticmap' Nothing) + (ClientEnv mgr googleMapsApis) + Just secret -> do + let url = fixUrl $ eval (safeLink api api) Nothing + signatureOpt = sign secret googleMapsApis url + runClientM (eval staticmap' signatureOpt) + (ClientEnv mgr googleMapsApis) + where + 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' + +-- A hack required because in package servant-0.9.1.1, the function `linkURI` +-- adds unwanted `[]` to specified parameter names for QueryParams (reported as +-- issue #715). The result is that `safeLink` does not return the correct URI. +-- The hack is not ideal as there is a very small but positive probability that +-- another part of the URI will contain by coincidence the characters that need +-- to be replaced. +fixUrl :: URI -> URI +fixUrl url = url {uriQuery = uri'} + where + uri = uriQuery url + uri' = replace "path[]=" "path=" $ replace "markers[]=" "markers=" $ replace + "style[]=" "style=" uri