@@ -1,11 +1,18 @@
11{-# LANGUAGE DeriveGeneric #-}
22{-# LANGUAGE ViewPatterns #-}
3−module Servant.Common.BaseUrl where
3+module Servant.Common.BaseUrl (
4+ -- * types
5+ BaseUrl (..)
6+ , InvalidBaseUrlException
7+ , Scheme (..)
8+ -- * functions
9+ , parseBaseUrl
10+ , showBaseUrl
11+) where
412
5−import Control.Monad.Catch (MonadThrow, throwM)
13+import Control.Monad.Catch (MonadThrow, throwM, Exception)
614import Data.List
715import GHC.Generics
8−import Network.HTTP.Client (HttpException(InvalidUrlException))
916import Network.URI
1017import Safe
1118import Text.Read
@@ -36,6 +43,9 @@ showBaseUrl (BaseUrl urlscheme host port) =
3643 (Https, 443) -> ""
3744 _ -> ":" ++ show port
3845
46+newtype InvalidBaseUrlException = InvalidBaseUrlException { _getInvalidUrlException :: String } deriving Show
47+instance Exception InvalidBaseUrlException
48+
3949parseBaseUrl :: MonadThrow m => String -> m BaseUrl
4050parseBaseUrl s = case parseURI (removeTrailingSlash s) of
4151 -- This is a rather hacky implementation and should be replaced with something
@@ -49,7 +59,7 @@ parseBaseUrl s = case parseURI (removeTrailingSlash s) of
4959 Just (URI "https:" (Just (URIAuth "" host "")) "" "" "") ->
5060 return (BaseUrl Https host 443)
5161 _ -> if "://" `isInfixOf` s
52− then throwM (InvalidUrlException s "Invalid base URL")
62+ then throwM (InvalidBaseUrlException $ "Invalid base URL: " ++ s)
5363 else parseBaseUrl ("http://" ++ s)
5464 where
5565 removeTrailingSlash str = case lastMay str of