core v0.2.0.0; client v0.3.0.0

ziptastic-client/CHANGELOG.md

@@ -1,5 +1,10 @@
 # Changelog
 
+## 0.3.0.0
+
+  * Detect if a `Manager` supports TLS and switch between HTTP and HTTPS automatically.
+  * Change LANGUAGE pragma formatting to support older GHCs.
+
 ## 0.2.0.0
 
   * For failures, provide full `ServantError` instead converting it to `String`.

ziptastic-client/src/Ziptastic/Client.hs

@@ -1,8 +1,4 @@
-{-# LANGUAGE
-    DataKinds
-  , TypeOperators
-  , OverloadedStrings
-#-}
+{-# LANGUAGE DataKinds, TypeOperators, OverloadedStrings #-}
 
 -- | This module provides a simple interface to Ziptastic's forward and reverse geocoding API
 -- (<https://www.getziptastic.com/>).
@@ -33,34 +29,39 @@ module Ziptastic.Client
 import           Data.ISO3166_CountryCodes (CountryCode)
 import           Data.Proxy (Proxy(..))
 import           Data.Text (Text)
-import           Network.HTTP.Client (Manager)
 import           Servant.API ((:<|>)(..))
 import           Servant.Client
-  ( BaseUrl(..), ClientEnv(..), ClientM, Scheme(..), ServantError
+  ( BaseUrl(..), ClientEnv(..), ClientM, Scheme(..), ServantError(..)
   , client, runClientM
   )
 
 import           Ziptastic.Core (ApiKey, ForApi(..), LocaleInfo)
 import qualified Ziptastic.Core as Core
 
+-- TODO: Needed for hack (see below).
+import           Network.HTTP.Client
+  ( Manager, HttpException(HttpExceptionRequest), HttpExceptionContent(TlsNotSupported) )
+import           Control.Exception (fromException)
+
 -- | Performs a forward geocode lookup at the given country and postal code.
 --
 -- The success result is a list because in rare cases you may receive multiple records.
 -- If the request fails the result will be 'Left' with an error.
 forwardGeocode :: ApiKey
-               -> Manager      -- ^ HTTP connection manager
+               -> Manager      -- ^ HTTP connection manager (if TLS is supported, request will be made over HTTPS)
                -> CountryCode  -- ^ country
                -> Text         -- ^ postal code
                -> IO (Either ServantError [LocaleInfo])
-forwardGeocode apiKey manager countryCode postalCode = runClientM func (ClientEnv manager baseUrl)
+forwardGeocode apiKey manager countryCode postalCode =
+  tryTlsOrDegrade $ \scheme -> runClientM func (ClientEnv manager $ baseUrl scheme)
   where func = forwardGeocode' (apiClient apiKey) (ForApi countryCode) postalCode
 
 -- | Performs a reverse geocode lookup at the given coordinates using a default radius of 5000 meters.
 --
 -- The success result is a list because in rare cases you may receive multiple records.
 -- If the request fails the result will be 'Left' with an error.
 reverseGeocode :: ApiKey
-               -> Manager -- ^ HTTP connection manager
+               -> Manager -- ^ HTTP connection manager (if TLS is supported, request will be made over HTTPS)
                -> Double  -- ^ latitude
                -> Double  -- ^ longitude
                -> IO (Either ServantError [LocaleInfo])
@@ -71,12 +72,13 @@ reverseGeocode apiKey manager lat long = reverseGeocodeWithRadius apiKey manager
 -- The success result is a list because in rare cases you may receive multiple records.
 -- If the request fails the result will be 'Left' with an error.
 reverseGeocodeWithRadius :: ApiKey
-                         -> Manager -- ^ HTTP connection manager
+                         -> Manager -- ^ HTTP connection manager (if TLS is supported, request will be made over HTTPS)
                          -> Double  -- ^ latitude
                          -> Double  -- ^ longitude
                          -> Int     -- ^ radius (in meters)
                          -> IO (Either ServantError [LocaleInfo])
-reverseGeocodeWithRadius apiKey manager lat long radius = runClientM func (ClientEnv manager baseUrl)
+reverseGeocodeWithRadius apiKey manager lat long radius =
+  tryTlsOrDegrade $ \scheme -> runClientM func (ClientEnv manager $ baseUrl scheme)
   where func = reverseGeocodeWithRadius' (mkReverseGeocode (apiClient apiKey) lat long) radius
 
 
@@ -104,11 +106,26 @@ apiClient apiKey = ApiClient
       where
         withRadius :<|> withDefaultRadius = reverseGeocodeApi lat long
 
-baseUrl :: BaseUrl
-baseUrl = BaseUrl
-  { baseUrlScheme = if Core.baseUrlIsHttps then Https else Http
+baseUrl :: Scheme -> BaseUrl
+baseUrl scheme = BaseUrl
+  { baseUrlScheme = scheme
   , baseUrlHost   = Core.baseUrlHost
-  , baseUrlPort   = Core.baseUrlPort
+  , baseUrlPort   = case scheme of
+      Http  -> 80
+      Https -> 443
   , baseUrlPath   = Core.baseUrlPath
   }
 
+
+-- TODO: Hack to detect if a Manager supports TLS.
+-- See https://github.com/snoyberg/http-client/issues/266
+tryTlsOrDegrade :: (Scheme -> IO (Either ServantError a)) -> IO (Either ServantError a)
+tryTlsOrDegrade req = do
+  secureResponse <- req Https
+  case secureResponse of
+    Left (ConnectionError connE) -> case fromException connE of
+      Just (ConnectionError connE2) -> case fromException connE2 of
+        Just (HttpExceptionRequest _ TlsNotSupported) -> req Http
+        _ -> pure secureResponse
+      _ -> pure secureResponse
+    _ -> pure secureResponse

ziptastic-client/test/Spec.hs

@@ -0,0 +1,34 @@
+{-# LANGUAGE LambdaCase, OverloadedStrings #-}
+
+module Main (main) where
+
+import           Data.ISO3166_CountryCodes (CountryCode(US))
+import           Network.HTTP.Client (newManager)
+import           Network.HTTP.Client (defaultManagerSettings)
+import           Network.HTTP.Client.TLS (tlsManagerSettings)
+import           Network.HTTP.Types.Status (unauthorized401)
+import           Servant.Client (ServantError(..))
+import           Test.Hspec
+import           Ziptastic.Client
+
+apiKey :: ApiKey
+apiKey = "fake-key"
+
+main :: IO ()
+main = do
+  insecureManager <- newManager defaultManagerSettings
+  secureManager   <- newManager tlsManagerSettings
+  hspec $
+    describe "http client machinery" $ do
+      it "can make requests with secure manager" $ do
+        response <- forwardGeocode apiKey secureManager US "48867"
+        response `shouldSatisfy` \case
+          Left (FailureResponse{responseStatus=status}) -> status == unauthorized401
+          _ -> False
+
+      it "can make requests with insecure manager" $ do
+        response <- forwardGeocode apiKey insecureManager US "48867"
+        response `shouldSatisfy` \case
+          Left (FailureResponse{responseStatus=status}) -> status == unauthorized401
+          _ -> False
+

ziptastic-client/ziptastic-client.cabal

@@ -1,5 +1,5 @@
 name:                ziptastic-client
-version:             0.2.0.0
+version:             0.3.0.0
 synopsis:
   A type-safe client for the Ziptastic API for doing forward and reverse geocoding.
 description:
@@ -18,7 +18,7 @@ category:            Web
 build-type:          Simple
 extra-source-files:  README.md
 cabal-version:       >=1.10
-tested-with:         GHC==8.0.2
+tested-with:         GHC == 8.0.2
 extra-source-files:
   CHANGELOG.md
   README.md
@@ -33,14 +33,31 @@ library
     , servant               >= 0.9 && <= 0.11
     , servant-client        >= 0.9 && <= 0.11
     , text
-    , ziptastic-core        == 0.1.0.1
+    , ziptastic-core        == 0.2.0.0
   default-language: Haskell2010
   other-extensions:
     DataKinds
     TypeOperators
     OverloadedStrings
   ghc-options: -Wall
 
+test-suite test-client
+  type:                exitcode-stdio-1.0
+  hs-source-dirs:      test
+  main-is:             Spec.hs
+  build-depends:
+      base
+    , hspec
+    , http-client
+    , http-client-tls
+    , http-types
+    , iso3166-country-codes
+    , servant-client
+    , ziptastic-client
+  ghc-options:      -threaded -rtsopts -with-rtsopts=-N
+  default-language: Haskell2010
+
+
 source-repository head
   type:     git
   location: https://github.com/Ziptastic/ziptastic-haskell

ziptastic-core/CHANGELOG.md

@@ -1,5 +1,10 @@
 # Changelog
 
+## 0.2.0.0
+
+  * Don't export scheme and port for base URL since Ziptastic supports both HTTP and HTTPS.
+  * Change LANGUAGE pragma formatting to support older GHCs.
+
 ## 0.1.0.1
 
   * Add version bounds.

ziptastic-core/src/Ziptastic/Core.hs

@@ -1,11 +1,4 @@
-{-# LANGUAGE
-    DataKinds
-  , DeriveGeneric
-  , FlexibleInstances
-  , GeneralizedNewtypeDeriving
-  , OverloadedStrings
-  , TypeOperators
-#-}
+{-# LANGUAGE DataKinds, DeriveGeneric, FlexibleInstances, GeneralizedNewtypeDeriving, OverloadedStrings, TypeOperators #-}
 
 -- | This module provides a complete and type-safe API specification for
 -- Ziptastic's forward and reverse geocoding API using Servant
@@ -19,9 +12,7 @@ module Ziptastic.Core
   , LocaleCoords(..)
   , LocaleInfo(..)
   , baseUrlHost
-  , baseUrlIsHttps
   , baseUrlPath
-  , baseUrlPort
   ) where
 
 import           Control.Monad (when)
@@ -125,14 +116,8 @@ type ReverseGeocodingApi
 
 
 -- API URL components
-baseUrlIsHttps :: Bool
-baseUrlIsHttps = True
-
 baseUrlHost :: String
 baseUrlHost = "zip.getziptastic.com"
 
-baseUrlPort :: Int
-baseUrlPort = 443
-
 baseUrlPath :: String
 baseUrlPath = ""

ziptastic-core/test/Spec.hs

@@ -1,7 +1,4 @@
-{-# LANGUAGE
-    OverloadedStrings
-  , QuasiQuotes
-#-}
+{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
 
 module Main (main) where
 

ziptastic-core/ziptastic-core.cabal

@@ -1,5 +1,5 @@
 name:                ziptastic-core
-version:             0.1.0.1
+version:             0.2.0.0
 synopsis:
   Core Servant specification for the Ziptastic API for doing forward and reverse geocoding.
 description:
@@ -20,7 +20,7 @@ category:            Web
 build-type:          Simple
 extra-source-files:  README.md
 cabal-version:       >=1.10
-tested-with:         GHC==8.0.2
+tested-with:         GHC == 8.0.2
 extra-source-files:
   CHANGELOG.md
   README.md