From 717b18df4e759c30765bdf56f709b0050c4220d4 Mon Sep 17 00:00:00 2001 From: Pierre Radermecker Date: Wed, 20 May 2015 21:54:10 +0200 Subject: [PATCH 1/5] Use MonadThrow instead of Either in the signature of parseBaseUrl --- servant-client/src/Servant/Common/BaseUrl.hs | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/servant-client/src/Servant/Common/BaseUrl.hs b/servant-client/src/Servant/Common/BaseUrl.hs index eae87c42..211c414c 100644 --- a/servant-client/src/Servant/Common/BaseUrl.hs +++ b/servant-client/src/Servant/Common/BaseUrl.hs @@ -2,8 +2,10 @@ {-# LANGUAGE ViewPatterns #-} module Servant.Common.BaseUrl where +import Control.Monad.Catch (MonadThrow, throwM) import Data.List import GHC.Generics +import Network.HTTP.Client (HttpException(InvalidUrlException)) import Network.URI import Safe import Text.Read @@ -34,20 +36,20 @@ showBaseUrl (BaseUrl urlscheme host port) = (Https, 443) -> "" _ -> ":" ++ show port -parseBaseUrl :: String -> Either String BaseUrl +parseBaseUrl :: MonadThrow m => String -> m BaseUrl parseBaseUrl s = case parseURI (removeTrailingSlash s) of -- This is a rather hacky implementation and should be replaced with something -- implemented in attoparsec (which is already a dependency anyhow (via aeson)). Just (URI "http:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") -> - Right (BaseUrl Http host port) + return (BaseUrl Http host port) Just (URI "http:" (Just (URIAuth "" host "")) "" "" "") -> - Right (BaseUrl Http host 80) + return (BaseUrl Http host 80) Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") -> - Right (BaseUrl Https host port) + return (BaseUrl Https host port) Just (URI "https:" (Just (URIAuth "" host "")) "" "" "") -> - Right (BaseUrl Https host 443) + return (BaseUrl Https host 443) _ -> if "://" `isInfixOf` s - then Left ("invalid base url: " ++ s) + then throwM (InvalidUrlException s "Invalid base URL") else parseBaseUrl ("http://" ++ s) where removeTrailingSlash str = case lastMay str of From 076286c37bd421137678c5a90fb6b9b895d3845f Mon Sep 17 00:00:00 2001 From: Pierre Radermecker Date: Thu, 21 May 2015 18:22:12 +0200 Subject: [PATCH 2/5] Add a Exception instance for ServantError --- servant-client/src/Servant/Common/Req.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs index b726e7a9..1204181b 100644 --- a/servant-client/src/Servant/Common/Req.hs +++ b/servant-client/src/Servant/Common/Req.hs @@ -55,6 +55,8 @@ data ServantError } deriving (Show) +instance Exception ServantError + data Req = Req { reqPath :: String , qs :: QueryText From 15b54cf1d0ba90591eced900a20047e18ff6b1ed Mon Sep 17 00:00:00 2001 From: Pierre Radermecker Date: Sat, 23 May 2015 14:55:12 +0200 Subject: [PATCH 3/5] Add AutoDeriveTypeable for ghc < 7.10 --- servant-client/src/Servant/Common/Req.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs index 1204181b..19d5ddce 100644 --- a/servant-client/src/Servant/Common/Req.hs +++ b/servant-client/src/Servant/Common/Req.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE AutoDeriveTypeable #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} From 520519bca9a61e4a0b9a4ffdf90610dcb523090c Mon Sep 17 00:00:00 2001 From: Pierre Radermecker Date: Wed, 27 May 2015 15:29:56 +0200 Subject: [PATCH 4/5] Remove deps on HttpException from http-client --- servant-client/src/Servant/Common/BaseUrl.hs | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/servant-client/src/Servant/Common/BaseUrl.hs b/servant-client/src/Servant/Common/BaseUrl.hs index 211c414c..3862821d 100644 --- a/servant-client/src/Servant/Common/BaseUrl.hs +++ b/servant-client/src/Servant/Common/BaseUrl.hs @@ -1,11 +1,18 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ViewPatterns #-} -module Servant.Common.BaseUrl where +module Servant.Common.BaseUrl ( + -- * types + BaseUrl (..) + , InvalidBaseUrlException + , Scheme (..) + -- * functions + , parseBaseUrl + , showBaseUrl +) where -import Control.Monad.Catch (MonadThrow, throwM) +import Control.Monad.Catch (MonadThrow, throwM, Exception) import Data.List import GHC.Generics -import Network.HTTP.Client (HttpException(InvalidUrlException)) import Network.URI import Safe import Text.Read @@ -36,6 +43,9 @@ showBaseUrl (BaseUrl urlscheme host port) = (Https, 443) -> "" _ -> ":" ++ show port +newtype InvalidBaseUrlException = InvalidBaseUrlException { _getInvalidUrlException :: String } deriving Show +instance Exception InvalidBaseUrlException + parseBaseUrl :: MonadThrow m => String -> m BaseUrl parseBaseUrl s = case parseURI (removeTrailingSlash s) of -- This is a rather hacky implementation and should be replaced with something @@ -49,7 +59,7 @@ parseBaseUrl s = case parseURI (removeTrailingSlash s) of Just (URI "https:" (Just (URIAuth "" host "")) "" "" "") -> return (BaseUrl Https host 443) _ -> if "://" `isInfixOf` s - then throwM (InvalidUrlException s "Invalid base URL") + then throwM (InvalidBaseUrlException $ "Invalid base URL: " ++ s) else parseBaseUrl ("http://" ++ s) where removeTrailingSlash str = case lastMay str of From 3bcbe80c378697bc3ef131fbf1b4403c42c41d80 Mon Sep 17 00:00:00 2001 From: Pierre Radermecker Date: Wed, 27 May 2015 22:25:08 +0200 Subject: [PATCH 5/5] Fix for GHC-7.8.x --- servant-client/src/Servant/Common/BaseUrl.hs | 8 +++++--- servant-client/src/Servant/Common/Req.hs | 5 +++-- 2 files changed, 8 insertions(+), 5 deletions(-) diff --git a/servant-client/src/Servant/Common/BaseUrl.hs b/servant-client/src/Servant/Common/BaseUrl.hs index 3862821d..f8cc61e2 100644 --- a/servant-client/src/Servant/Common/BaseUrl.hs +++ b/servant-client/src/Servant/Common/BaseUrl.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ViewPatterns #-} module Servant.Common.BaseUrl ( -- * types BaseUrl (..) @@ -12,6 +13,7 @@ module Servant.Common.BaseUrl ( import Control.Monad.Catch (MonadThrow, throwM, Exception) import Data.List +import Data.Typeable import GHC.Generics import Network.URI import Safe @@ -43,7 +45,7 @@ showBaseUrl (BaseUrl urlscheme host port) = (Https, 443) -> "" _ -> ":" ++ show port -newtype InvalidBaseUrlException = InvalidBaseUrlException { _getInvalidUrlException :: String } deriving Show +data InvalidBaseUrlException = InvalidBaseUrlException String deriving (Show, Typeable) instance Exception InvalidBaseUrlException parseBaseUrl :: MonadThrow m => String -> m BaseUrl diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs index 19d5ddce..ac2c3dba 100644 --- a/servant-client/src/Servant/Common/Req.hs +++ b/servant-client/src/Servant/Common/Req.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -19,6 +19,7 @@ import Data.String.Conversions import Data.Proxy import Data.Text (Text) import Data.Text.Encoding +import Data.Typeable import Network.HTTP.Client hiding (Proxy) import Network.HTTP.Client.TLS import Network.HTTP.Media @@ -54,7 +55,7 @@ data ServantError { responseContentTypeHeader :: ByteString , responseBody :: ByteString } - deriving (Show) + deriving (Show, Typeable) instance Exception ServantError