@@ -2,8 +2,10 @@
2{-# LANGUAGE ViewPatterns #-}
2{-# LANGUAGE ViewPatterns #-}
3module Servant.Common.BaseUrl where
3module Servant.Common.BaseUrl where
5+import Control.Monad.Catch (MonadThrow, throwM)
5import Data.List
6import Data.List
6import GHC.Generics
7import GHC.Generics
8+import Network.HTTP.Client (HttpException(InvalidUrlException))
7import Network.URI
9import Network.URI
8import Safe
10import Safe
9import Text.Read
11import Text.Read
@@ -34,20 +36,20 @@ showBaseUrl (BaseUrl urlscheme host port) =
34 (Https, 443) -> ""
36 (Https, 443) -> ""
35 _ -> ":" ++ show port
37 _ -> ":" ++ show port
37−parseBaseUrl :: String -> Either String BaseUrl
39+parseBaseUrl :: MonadThrow m => String -> m BaseUrl
38parseBaseUrl s = case parseURI (removeTrailingSlash s) of
40parseBaseUrl s = case parseURI (removeTrailingSlash s) of
39 -- This is a rather hacky implementation and should be replaced with something
41 -- This is a rather hacky implementation and should be replaced with something
40 -- implemented in attoparsec (which is already a dependency anyhow (via aeson)).
42 -- implemented in attoparsec (which is already a dependency anyhow (via aeson)).
41 Just (URI "http:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") ->
43 Just (URI "http:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") ->
42− Right (BaseUrl Http host port)
44+ return (BaseUrl Http host port)
43 Just (URI "http:" (Just (URIAuth "" host "")) "" "" "") ->
45 Just (URI "http:" (Just (URIAuth "" host "")) "" "" "") ->
44− Right (BaseUrl Http host 80)
46+ return (BaseUrl Http host 80)
45 Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") ->
47 Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") ->
46− Right (BaseUrl Https host port)
48+ return (BaseUrl Https host port)
47 Just (URI "https:" (Just (URIAuth "" host "")) "" "" "") ->
49 Just (URI "https:" (Just (URIAuth "" host "")) "" "" "") ->
48− Right (BaseUrl Https host 443)
50+ return (BaseUrl Https host 443)
49 _ -> if "://" `isInfixOf` s
51 _ -> if "://" `isInfixOf` s
50− then Left ("invalid base url: " ++ s)
52+ then throwM (InvalidUrlException s "Invalid base URL")
51 else parseBaseUrl ("http://" ++ s)
53 else parseBaseUrl ("http://" ++ s)
53 removeTrailingSlash str = case lastMay str of
55 removeTrailingSlash str = case lastMay str of