{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE DeriveLift         #-}
{-# LANGUAGE ViewPatterns       #-}
module Servant.Client.Core.BaseUrl (
    BaseUrl (..),
    Scheme (..),
    showBaseUrl,
    parseBaseUrl,
    InvalidBaseUrlException (..),
    ) where

import           Control.DeepSeq
                 (NFData (..))
import           Control.Monad.Catch
                 (Exception, MonadThrow, throwM)
import           Data.Aeson
                 (FromJSON (..), FromJSONKey (..), ToJSON (..), ToJSONKey (..))
import           Data.Aeson.Types
                 (FromJSONKeyFunction (..), contramapToJSONKeyFunction,
                 withText)
import           Data.Data
                 (Data)
import           Data.List
import qualified Data.Text                  as T
import           GHC.Generics
import           Language.Haskell.TH.Syntax
                 (Lift)
import           Network.URI                hiding
                 (path)
import           Safe
import           Text.Read

-- | URI scheme to use
data Scheme =
    Http  -- ^ http://
  | Https -- ^ https://
  deriving (Int -> Scheme -> ShowS
[Scheme] -> ShowS
Scheme -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Scheme] -> ShowS
$cshowList :: [Scheme] -> ShowS
show :: Scheme -> String
$cshow :: Scheme -> String
showsPrec :: Int -> Scheme -> ShowS
$cshowsPrec :: Int -> Scheme -> ShowS
Show, Scheme -> Scheme -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Scheme -> Scheme -> Bool
$c/= :: Scheme -> Scheme -> Bool
== :: Scheme -> Scheme -> Bool
$c== :: Scheme -> Scheme -> Bool
Eq, Eq Scheme
Scheme -> Scheme -> Bool
Scheme -> Scheme -> Ordering
Scheme -> Scheme -> Scheme
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Scheme -> Scheme -> Scheme
$cmin :: Scheme -> Scheme -> Scheme
max :: Scheme -> Scheme -> Scheme
$cmax :: Scheme -> Scheme -> Scheme
>= :: Scheme -> Scheme -> Bool
$c>= :: Scheme -> Scheme -> Bool
> :: Scheme -> Scheme -> Bool
$c> :: Scheme -> Scheme -> Bool
<= :: Scheme -> Scheme -> Bool
$c<= :: Scheme -> Scheme -> Bool
< :: Scheme -> Scheme -> Bool
$c< :: Scheme -> Scheme -> Bool
compare :: Scheme -> Scheme -> Ordering
$ccompare :: Scheme -> Scheme -> Ordering
Ord, forall x. Rep Scheme x -> Scheme
forall x. Scheme -> Rep Scheme x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Scheme x -> Scheme
$cfrom :: forall x. Scheme -> Rep Scheme x
Generic, forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Scheme -> m Exp
forall (m :: * -> *). Quote m => Scheme -> Code m Scheme
liftTyped :: forall (m :: * -> *). Quote m => Scheme -> Code m Scheme
$cliftTyped :: forall (m :: * -> *). Quote m => Scheme -> Code m Scheme
lift :: forall (m :: * -> *). Quote m => Scheme -> m Exp
$clift :: forall (m :: * -> *). Quote m => Scheme -> m Exp
Lift, Typeable Scheme
Scheme -> DataType
Scheme -> Constr
(forall b. Data b => b -> b) -> Scheme -> Scheme
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> Scheme -> u
forall u. (forall d. Data d => d -> u) -> Scheme -> [u]
forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Scheme -> r
forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Scheme -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Scheme -> m Scheme
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Scheme -> m Scheme
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Scheme
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Scheme -> c Scheme
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Scheme)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Scheme)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Scheme -> m Scheme
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Scheme -> m Scheme
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Scheme -> m Scheme
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Scheme -> m Scheme
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Scheme -> m Scheme
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Scheme -> m Scheme
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Scheme -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Scheme -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> Scheme -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Scheme -> [u]
gmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Scheme -> r
$cgmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Scheme -> r
gmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Scheme -> r
$cgmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Scheme -> r
gmapT :: (forall b. Data b => b -> b) -> Scheme -> Scheme
$cgmapT :: (forall b. Data b => b -> b) -> Scheme -> Scheme
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Scheme)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Scheme)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Scheme)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Scheme)
dataTypeOf :: Scheme -> DataType
$cdataTypeOf :: Scheme -> DataType
toConstr :: Scheme -> Constr
$ctoConstr :: Scheme -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Scheme
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Scheme
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Scheme -> c Scheme
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Scheme -> c Scheme
Data)

-- | Simple data type to represent the target of HTTP requests
--   for servant's automatically-generated clients.
data BaseUrl = BaseUrl
  { BaseUrl -> Scheme
baseUrlScheme :: Scheme   -- ^ URI scheme to use
  , BaseUrl -> String
baseUrlHost   :: String   -- ^ host (eg "haskell.org")
  , BaseUrl -> Int
baseUrlPort   :: Int      -- ^ port (eg 80)
  , BaseUrl -> String
baseUrlPath   :: String   -- ^ path (eg "/a/b/c")
  } deriving (Int -> BaseUrl -> ShowS
[BaseUrl] -> ShowS
BaseUrl -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BaseUrl] -> ShowS
$cshowList :: [BaseUrl] -> ShowS
show :: BaseUrl -> String
$cshow :: BaseUrl -> String
showsPrec :: Int -> BaseUrl -> ShowS
$cshowsPrec :: Int -> BaseUrl -> ShowS
Show, Eq BaseUrl
BaseUrl -> BaseUrl -> Bool
BaseUrl -> BaseUrl -> Ordering
BaseUrl -> BaseUrl -> BaseUrl
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BaseUrl -> BaseUrl -> BaseUrl
$cmin :: BaseUrl -> BaseUrl -> BaseUrl
max :: BaseUrl -> BaseUrl -> BaseUrl
$cmax :: BaseUrl -> BaseUrl -> BaseUrl
>= :: BaseUrl -> BaseUrl -> Bool
$c>= :: BaseUrl -> BaseUrl -> Bool
> :: BaseUrl -> BaseUrl -> Bool
$c> :: BaseUrl -> BaseUrl -> Bool
<= :: BaseUrl -> BaseUrl -> Bool
$c<= :: BaseUrl -> BaseUrl -> Bool
< :: BaseUrl -> BaseUrl -> Bool
$c< :: BaseUrl -> BaseUrl -> Bool
compare :: BaseUrl -> BaseUrl -> Ordering
$ccompare :: BaseUrl -> BaseUrl -> Ordering
Ord, forall x. Rep BaseUrl x -> BaseUrl
forall x. BaseUrl -> Rep BaseUrl x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep BaseUrl x -> BaseUrl
$cfrom :: forall x. BaseUrl -> Rep BaseUrl x
Generic, forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => BaseUrl -> m Exp
forall (m :: * -> *). Quote m => BaseUrl -> Code m BaseUrl
liftTyped :: forall (m :: * -> *). Quote m => BaseUrl -> Code m BaseUrl
$cliftTyped :: forall (m :: * -> *). Quote m => BaseUrl -> Code m BaseUrl
lift :: forall (m :: * -> *). Quote m => BaseUrl -> m Exp
$clift :: forall (m :: * -> *). Quote m => BaseUrl -> m Exp
Lift, Typeable BaseUrl
BaseUrl -> DataType
BaseUrl -> Constr
(forall b. Data b => b -> b) -> BaseUrl -> BaseUrl
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> BaseUrl -> u
forall u. (forall d. Data d => d -> u) -> BaseUrl -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> BaseUrl -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> BaseUrl -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> BaseUrl -> m BaseUrl
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> BaseUrl -> m BaseUrl
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c BaseUrl
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> BaseUrl -> c BaseUrl
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c BaseUrl)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c BaseUrl)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> BaseUrl -> m BaseUrl
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> BaseUrl -> m BaseUrl
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> BaseUrl -> m BaseUrl
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> BaseUrl -> m BaseUrl
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> BaseUrl -> m BaseUrl
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> BaseUrl -> m BaseUrl
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> BaseUrl -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> BaseUrl -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> BaseUrl -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> BaseUrl -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> BaseUrl -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> BaseUrl -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> BaseUrl -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> BaseUrl -> r
gmapT :: (forall b. Data b => b -> b) -> BaseUrl -> BaseUrl
$cgmapT :: (forall b. Data b => b -> b) -> BaseUrl -> BaseUrl
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c BaseUrl)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c BaseUrl)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c BaseUrl)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c BaseUrl)
dataTypeOf :: BaseUrl -> DataType
$cdataTypeOf :: BaseUrl -> DataType
toConstr :: BaseUrl -> Constr
$ctoConstr :: BaseUrl -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c BaseUrl
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c BaseUrl
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> BaseUrl -> c BaseUrl
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> BaseUrl -> c BaseUrl
Data)
-- TODO: Ord is more precise than Eq
-- TODO: Add Hashable instance?
--
instance NFData BaseUrl where
  rnf :: BaseUrl -> ()
rnf (BaseUrl Scheme
a String
b Int
c String
d) = Scheme
a seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf String
b seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf Int
c seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf String
d

instance Eq BaseUrl where
    BaseUrl Scheme
a String
b Int
c String
path == :: BaseUrl -> BaseUrl -> Bool
== BaseUrl Scheme
a' String
b' Int
c' String
path'
        = Scheme
a forall a. Eq a => a -> a -> Bool
== Scheme
a' Bool -> Bool -> Bool
&& String
b forall a. Eq a => a -> a -> Bool
== String
b' Bool -> Bool -> Bool
&& Int
c forall a. Eq a => a -> a -> Bool
== Int
c' Bool -> Bool -> Bool
&& ShowS
s String
path forall a. Eq a => a -> a -> Bool
== ShowS
s String
path'
        where s :: ShowS
s (Char
'/':String
x) = String
x
              s String
x       = String
x

-- | >>> traverse_ (LBS8.putStrLn . encode) (parseBaseUrl "api.example.com" :: [BaseUrl])
-- "http://api.example.com"
instance ToJSON BaseUrl where
    toJSON :: BaseUrl -> Value
toJSON     = forall a. ToJSON a => a -> Value
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. BaseUrl -> String
showBaseUrl
    toEncoding :: BaseUrl -> Encoding
toEncoding = forall a. ToJSON a => a -> Encoding
toEncoding forall b c a. (b -> c) -> (a -> b) -> a -> c
. BaseUrl -> String
showBaseUrl

-- | >>> parseBaseUrl "api.example.com" >>= decode . encode :: Maybe BaseUrl
-- Just (BaseUrl {baseUrlScheme = Http, baseUrlHost = "api.example.com", baseUrlPort = 80, baseUrlPath = ""})
instance FromJSON BaseUrl where
    parseJSON :: Value -> Parser BaseUrl
parseJSON = forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"BaseUrl" forall a b. (a -> b) -> a -> b
$ \Text
t -> case forall (m :: * -> *). MonadThrow m => String -> m BaseUrl
parseBaseUrl (Text -> String
T.unpack Text
t) of
        Just BaseUrl
u  -> forall (m :: * -> *) a. Monad m => a -> m a
return BaseUrl
u
        Maybe BaseUrl
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Invalid base url: " forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
t

-- | >>> :{
-- traverse_ (LBS8.putStrLn . encode) $ do
--   u1 <- parseBaseUrl "api.example.com" :: [BaseUrl]
--   u2 <- parseBaseUrl "example.com" :: [BaseUrl]
--   return $ Map.fromList [(u1, 'x'), (u2, 'y')]
-- :}
-- {"http://api.example.com":"x","http://example.com":"y"}
instance ToJSONKey BaseUrl where
    toJSONKey :: ToJSONKeyFunction BaseUrl
toJSONKey = forall b a. (b -> a) -> ToJSONKeyFunction a -> ToJSONKeyFunction b
contramapToJSONKeyFunction BaseUrl -> String
showBaseUrl forall a. ToJSONKey a => ToJSONKeyFunction a
toJSONKey

instance FromJSONKey BaseUrl where
    fromJSONKey :: FromJSONKeyFunction BaseUrl
fromJSONKey = forall a. (Text -> Parser a) -> FromJSONKeyFunction a
FromJSONKeyTextParser forall a b. (a -> b) -> a -> b
$ \Text
t -> case forall (m :: * -> *). MonadThrow m => String -> m BaseUrl
parseBaseUrl (Text -> String
T.unpack Text
t) of
        Just BaseUrl
u  -> forall (m :: * -> *) a. Monad m => a -> m a
return BaseUrl
u
        Maybe BaseUrl
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Invalid base url: " forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
t

-- | >>> showBaseUrl <$> parseBaseUrl "api.example.com"
-- "http://api.example.com"
showBaseUrl :: BaseUrl -> String
showBaseUrl :: BaseUrl -> String
showBaseUrl (BaseUrl Scheme
urlscheme String
host Int
port String
path) =
  String
schemeString forall a. [a] -> [a] -> [a]
++ String
"//" forall a. [a] -> [a] -> [a]
++ String
host forall a. [a] -> [a] -> [a]
++ (String
portString String -> ShowS
</> String
path)
    where
      String
a </> :: String -> ShowS
</> String
b = if String
"/" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
b Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
b then String
a forall a. [a] -> [a] -> [a]
++ String
b else String
a forall a. [a] -> [a] -> [a]
++ Char
'/'forall a. a -> [a] -> [a]
:String
b
      schemeString :: String
schemeString = case Scheme
urlscheme of
        Scheme
Http  -> String
"http:"
        Scheme
Https -> String
"https:"
      portString :: String
portString = case (Scheme
urlscheme, Int
port) of
        (Scheme
Http, Int
80) -> String
""
        (Scheme
Https, Int
443) -> String
""
        (Scheme, Int)
_ -> String
":" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
port

newtype InvalidBaseUrlException = InvalidBaseUrlException String deriving (Int -> InvalidBaseUrlException -> ShowS
[InvalidBaseUrlException] -> ShowS
InvalidBaseUrlException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InvalidBaseUrlException] -> ShowS
$cshowList :: [InvalidBaseUrlException] -> ShowS
show :: InvalidBaseUrlException -> String
$cshow :: InvalidBaseUrlException -> String
showsPrec :: Int -> InvalidBaseUrlException -> ShowS
$cshowsPrec :: Int -> InvalidBaseUrlException -> ShowS
Show)
instance Exception InvalidBaseUrlException

-- |
--
-- >>> parseBaseUrl "api.example.com"
-- BaseUrl {baseUrlScheme = Http, baseUrlHost = "api.example.com", baseUrlPort = 80, baseUrlPath = ""}
--
-- /Note:/ trailing slash is removed
--
-- >>> parseBaseUrl "api.example.com/"
-- BaseUrl {baseUrlScheme = Http, baseUrlHost = "api.example.com", baseUrlPort = 80, baseUrlPath = ""}
--
-- >>> parseBaseUrl "api.example.com/dir/"
-- BaseUrl {baseUrlScheme = Http, baseUrlHost = "api.example.com", baseUrlPort = 80, baseUrlPath = "/dir"}
--
parseBaseUrl :: MonadThrow m => String -> m BaseUrl
parseBaseUrl :: forall (m :: * -> *). MonadThrow m => String -> m BaseUrl
parseBaseUrl String
s = case String -> Maybe URI
parseURI (ShowS
removeTrailingSlash String
s) of
  -- This is a rather hacky implementation and should be replaced with something
  -- implemented in attoparsec (which is already a dependency anyhow (via aeson)).
  Just (URI String
"http:" (Just (URIAuth String
"" String
host (Char
':' : (forall a. Read a => String -> Maybe a
readMaybe -> Just Int
port)))) String
path String
"" String
"") ->
    forall (m :: * -> *) a. Monad m => a -> m a
return (Scheme -> String -> Int -> String -> BaseUrl
BaseUrl Scheme
Http String
host Int
port String
path)
  Just (URI String
"http:" (Just (URIAuth String
"" String
host String
"")) String
path String
"" String
"") ->
    forall (m :: * -> *) a. Monad m => a -> m a
return (Scheme -> String -> Int -> String -> BaseUrl
BaseUrl Scheme
Http String
host Int
80 String
path)
  Just (URI String
"https:" (Just (URIAuth String
"" String
host (Char
':' : (forall a. Read a => String -> Maybe a
readMaybe -> Just Int
port)))) String
path String
"" String
"") ->
    forall (m :: * -> *) a. Monad m => a -> m a
return (Scheme -> String -> Int -> String -> BaseUrl
BaseUrl Scheme
Https String
host Int
port String
path)
  Just (URI String
"https:" (Just (URIAuth String
"" String
host String
"")) String
path String
"" String
"") ->
    forall (m :: * -> *) a. Monad m => a -> m a
return (Scheme -> String -> Int -> String -> BaseUrl
BaseUrl Scheme
Https String
host Int
443 String
path)
  Maybe URI
_ -> if String
"://" forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
s
    then forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (String -> InvalidBaseUrlException
InvalidBaseUrlException forall a b. (a -> b) -> a -> b
$ String
"Invalid base URL: " forall a. [a] -> [a] -> [a]
++ String
s)
    else forall (m :: * -> *). MonadThrow m => String -> m BaseUrl
parseBaseUrl (String
"http://" forall a. [a] -> [a] -> [a]
++ String
s)
 where
  removeTrailingSlash :: ShowS
removeTrailingSlash String
str = case forall a. [a] -> Maybe a
lastMay String
str of
    Just Char
'/' -> forall a. [a] -> [a]
init String
str
    Maybe Char
_ -> String
str

-- $setup
--
-- >>> import Data.Aeson
-- >>> import Data.Foldable (traverse_)
-- >>> import qualified Data.ByteString.Lazy.Char8 as LBS8
-- >>> import qualified Data.Map.Strict as Map