@@ -2,8 +2,10 @@
22{-# LANGUAGE ViewPatterns #-}
33module Servant.Common.BaseUrl where
44
5+import Control.Monad.Catch (MonadThrow, throwM)
56import Data.List
67import GHC.Generics
8+import Network.HTTP.Client (HttpException(InvalidUrlException))
79import Network.URI
810import Safe
911import Text.Read
@@ -34,20 +36,20 @@ showBaseUrl (BaseUrl urlscheme host port) =
3436 (Https, 443) -> ""
3537 _ -> ":" ++ show port
3638
37−parseBaseUrl :: String -> Either String BaseUrl
39+parseBaseUrl :: MonadThrow m => String -> m BaseUrl
3840parseBaseUrl s = case parseURI (removeTrailingSlash s) of
3941 -- This is a rather hacky implementation and should be replaced with something
4042 -- implemented in attoparsec (which is already a dependency anyhow (via aeson)).
4143 Just (URI "http:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") ->
42− Right (BaseUrl Http host port)
44+ return (BaseUrl Http host port)
4345 Just (URI "http:" (Just (URIAuth "" host "")) "" "" "") ->
44− Right (BaseUrl Http host 80)
46+ return (BaseUrl Http host 80)
4547 Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") ->
46− Right (BaseUrl Https host port)
48+ return (BaseUrl Https host port)
4749 Just (URI "https:" (Just (URIAuth "" host "")) "" "" "") ->
48− Right (BaseUrl Https host 443)
50+ return (BaseUrl Https host 443)
4951 _ -> if "://" `isInfixOf` s
50− then Left ("invalid base url: " ++ s)
52+ then throwM (InvalidUrlException s "Invalid base URL")
5153 else parseBaseUrl ("http://" ++ s)
5254 where
5355 removeTrailingSlash str = case lastMay str of