eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Remove deps on HttpException from http-client

Browse source
This commit is contained in:
Pierre Radermecker 2015-05-27 15:29:56 +02:00
parent 15b54cf1d0
commit 520519bca9
1 changed files with 14 additions and 4 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

18
servant-client/src/Servant/Common/BaseUrl.hs
View file

@ -1,11 +1,18 @@
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ViewPatterns #-} {-# 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 Data.List
import GHC.Generics import GHC.Generics
import Network.HTTP.Client (HttpException(InvalidUrlException))
import Network.URI import Network.URI
import Safe import Safe
import Text.Read import Text.Read
@ -36,6 +43,9 @@ showBaseUrl (BaseUrl urlscheme host port) =
(Https, 443) -> "" (Https, 443) -> ""
_ -> ":" ++ show port _ -> ":" ++ show port
newtype InvalidBaseUrlException = InvalidBaseUrlException { _getInvalidUrlException :: String } deriving Show
instance Exception InvalidBaseUrlException
parseBaseUrl :: MonadThrow m => String -> m BaseUrl parseBaseUrl :: MonadThrow m => String -> m BaseUrl
parseBaseUrl s = case parseURI (removeTrailingSlash s) of parseBaseUrl s = case parseURI (removeTrailingSlash s) of
-- This is a rather hacky implementation and should be replaced with something -- 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 "")) "" "" "") -> Just (URI "https:" (Just (URIAuth "" host "")) "" "" "") ->
return (BaseUrl Https host 443) return (BaseUrl Https host 443)
_ -> if "://" `isInfixOf` s _ -> if "://" `isInfixOf` s
then throwM (InvalidUrlException s "Invalid base URL") then throwM (InvalidBaseUrlException $ "Invalid base URL: " ++ s)
else parseBaseUrl ("http://" ++ s) else parseBaseUrl ("http://" ++ s)
where where
removeTrailingSlash str = case lastMay str of removeTrailingSlash str = case lastMay str of