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

Use MonadThrow instead of Either in the signature of parseBaseUrl

Browse source
This commit is contained in:
Pierre Radermecker 2015-05-20 21:54:10 +02:00
parent c6467e2e70
commit 717b18df4e
1 changed files with 8 additions and 6 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -2,8 +2,10 @@
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
module Servant.Common.BaseUrl where module Servant.Common.BaseUrl where
import Control.Monad.Catch (MonadThrow, throwM)
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
@ -34,20 +36,20 @@ showBaseUrl (BaseUrl urlscheme host port) =
(Https, 443) -> "" (Https, 443) -> ""
_ -> ":" ++ show port _ -> ":" ++ show port
parseBaseUrl :: String -> Either String 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
-- implemented in attoparsec (which is already a dependency anyhow (via aeson)). -- implemented in attoparsec (which is already a dependency anyhow (via aeson)).
Just (URI "http:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") -> 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 "")) "" "" "") -> 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)))) "" "" "") -> 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 "")) "" "" "") -> Just (URI "https:" (Just (URIAuth "" host "")) "" "" "") ->
Right (BaseUrl Https host 443) return (BaseUrl Https host 443)
_ -> if "://" `isInfixOf` s _ -> if "://" `isInfixOf` s
then Left ("invalid base url: " ++ s) then throwM (InvalidUrlException s "Invalid base URL")
else parseBaseUrl ("http://" ++ s) else parseBaseUrl ("http://" ++ s)
where where
removeTrailingSlash str = case lastMay str of removeTrailingSlash str = case lastMay str of