@@ -1,8 +1,19 @@
1−{-# LANGUAGE DeriveGeneric #-}
2−{-# LANGUAGE ViewPatterns #-}
3−module Servant.Common.BaseUrl where
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE ViewPatterns #-}
4+module Servant.Common.BaseUrl (
5+ -- * types
6+ BaseUrl (..)
7+ , InvalidBaseUrlException
8+ , Scheme (..)
9+ -- * functions
10+ , parseBaseUrl
11+ , showBaseUrl
12+) where
413
14+import Control.Monad.Catch (MonadThrow, throwM, Exception)
515import Data.List
16+import Data.Typeable
617import GHC.Generics
718import Network.URI
819import Safe
@@ -34,20 +45,23 @@ showBaseUrl (BaseUrl urlscheme host port) =
3445 (Https, 443) -> ""
3546 _ -> ":" ++ show port
3647
37−parseBaseUrl :: String -> Either String BaseUrl
48+data InvalidBaseUrlException = InvalidBaseUrlException String deriving (Show, Typeable)
49+instance Exception InvalidBaseUrlException
50+
51+parseBaseUrl :: MonadThrow m => String -> m BaseUrl
3852parseBaseUrl s = case parseURI (removeTrailingSlash s) of
3953 -- This is a rather hacky implementation and should be replaced with something
4054 -- implemented in attoparsec (which is already a dependency anyhow (via aeson)).
4155 Just (URI "http:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") ->
42− Right (BaseUrl Http host port)
56+ return (BaseUrl Http host port)
4357 Just (URI "http:" (Just (URIAuth "" host "")) "" "" "") ->
44− Right (BaseUrl Http host 80)
58+ return (BaseUrl Http host 80)
4559 Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") ->
46− Right (BaseUrl Https host port)
60+ return (BaseUrl Https host port)
4761 Just (URI "https:" (Just (URIAuth "" host "")) "" "" "") ->
48− Right (BaseUrl Https host 443)
62+ return (BaseUrl Https host 443)
4963 _ -> if "://" `isInfixOf` s
50− then Left ("invalid base url: " ++ s)
64+ then throwM (InvalidBaseUrlException $ "Invalid base URL: " ++ s)
5165 else parseBaseUrl ("http://" ++ s)
5266 where
5367 removeTrailingSlash str = case lastMay str of