@@ -1,14 +1,24 @@
11{-# LANGUAGE DeriveDataTypeable #-}
22{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DeriveLift #-}
34{-# LANGUAGE ViewPatterns #-}
45module Servant.Client.Core.Internal.BaseUrl where
56
67import Control.Monad.Catch
78 (Exception, MonadThrow, throwM)
9+import Data.Aeson
10+ (FromJSON (..), FromJSONKey (..), ToJSON (..), ToJSONKey (..))
11+import Data.Aeson.Types
12+ (FromJSONKeyFunction (..), contramapToJSONKeyFunction,
13+ withText)
14+import Data.Data
15+ (Data)
816import Data.List
9−import Data.Typeable
17+import qualified Data.Text as T
1018import GHC.Generics
11−import Network.URI hiding
19+import Language.Haskell.TH.Syntax
20+ (Lift)
21+import Network.URI hiding
1222 (path)
1323import Safe
1424import Text.Read
@@ -17,16 +27,18 @@ import Text.Read
1727data Scheme =
1828 Http -- ^ http://
1929 | Https -- ^ https://
20− deriving (Show, Eq, Ord, Generic)
30+ deriving (Show, Eq, Ord, Generic, Lift, Data)
2131
2232-- | Simple data type to represent the target of HTTP requests
2333-- for servant's automatically-generated clients.
2434data BaseUrl = BaseUrl
25− { baseUrlScheme :: Scheme -- ^ URI scheme to use
35+ { baseUrlScheme :: Scheme -- ^ URI scheme to use
2636 , baseUrlHost :: String -- ^ host (eg "haskell.org")
2737 , baseUrlPort :: Int -- ^ port (eg 80)
2838 , baseUrlPath :: String -- ^ path (eg "/a/b/c")
29− } deriving (Show, Ord, Generic)
39+ } deriving (Show, Ord, Generic, Lift, Data)
40+-- TODO: Ord is more precise than Eq
41+-- TODO: Add Hashable instance?
3042
3143instance Eq BaseUrl where
3244 BaseUrl a b c path == BaseUrl a' b' c' path'
@@ -34,6 +46,36 @@ instance Eq BaseUrl where
3446 where s ('/':x) = x
3547 s x = x
3648
49+-- | >>> traverse_ (LBS8.putStrLn . encode) $ parseBaseUrl "api.example.com"
50+-- "http://api.example.com"
51+instance ToJSON BaseUrl where
52+ toJSON = toJSON . showBaseUrl
53+ toEncoding = toEncoding . showBaseUrl
54+
55+-- | >>> parseBaseUrl "api.example.com" >>= decode . encode :: Maybe BaseUrl
56+-- Just (BaseUrl {baseUrlScheme = Http, baseUrlHost = "api.example.com", baseUrlPort = 80, baseUrlPath = ""})
57+instance FromJSON BaseUrl where
58+ parseJSON = withText "BaseUrl" $ \t -> case parseBaseUrl (T.unpack t) of
59+ Just u -> return u
60+ Nothing -> fail $ "Invalid base url: " ++ T.unpack t
61+
62+-- | >>> :{
63+-- traverse_ (LBS8.putStrLn . encode) $ do
64+-- u1 <- parseBaseUrl "api.example.com"
65+-- u2 <- parseBaseUrl "example.com"
66+-- return $ Map.fromList [(u1, 'x'), (u2, 'y')]
67+-- :}
68+-- {"http://api.example.com":"x","http://example.com":"y"}
69+instance ToJSONKey BaseUrl where
70+ toJSONKey = contramapToJSONKeyFunction showBaseUrl toJSONKey
71+
72+instance FromJSONKey BaseUrl where
73+ fromJSONKey = FromJSONKeyTextParser $ \t -> case parseBaseUrl (T.unpack t) of
74+ Just u -> return u
75+ Nothing -> fail $ "Invalid base url: " ++ T.unpack t
76+
77+-- | >>> showBaseUrl <$> parseBaseUrl "api.example.com"
78+-- "http://api.example.com"
3779showBaseUrl :: BaseUrl -> String
3880showBaseUrl (BaseUrl urlscheme host port path) =
3981 schemeString ++ "//" ++ host ++ (portString </> path)
@@ -47,9 +89,22 @@ showBaseUrl (BaseUrl urlscheme host port path) =
4789 (Https, 443) -> ""
4890 _ -> ":" ++ show port
4991
50−data InvalidBaseUrlException = InvalidBaseUrlException String deriving (Show, Typeable)
92+newtype InvalidBaseUrlException = InvalidBaseUrlException String deriving (Show)
5193instance Exception InvalidBaseUrlException
5294
95+-- |
96+--
97+-- >>> parseBaseUrl "api.example.com"
98+-- BaseUrl {baseUrlScheme = Http, baseUrlHost = "api.example.com", baseUrlPort = 80, baseUrlPath = ""}
99+--
100+-- /Note:/ trailing slash is removed
101+--
102+-- >>> parseBaseUrl "api.example.com/"
103+-- BaseUrl {baseUrlScheme = Http, baseUrlHost = "api.example.com", baseUrlPort = 80, baseUrlPath = ""}
104+--
105+-- >>> parseBaseUrl "api.example.com/dir/"
106+-- BaseUrl {baseUrlScheme = Http, baseUrlHost = "api.example.com", baseUrlPort = 80, baseUrlPath = "/dir"}
107+--
53108parseBaseUrl :: MonadThrow m => String -> m BaseUrl
54109parseBaseUrl s = case parseURI (removeTrailingSlash s) of
55110 -- This is a rather hacky implementation and should be replaced with something
@@ -69,3 +124,10 @@ parseBaseUrl s = case parseURI (removeTrailingSlash s) of
69124 removeTrailingSlash str = case lastMay str of
70125 Just '/' -> init str
71126 _ -> str
127+
128+-- $setup
129+--
130+-- >>> import Data.Aeson
131+-- >>> import Data.Foldable (traverse_)
132+-- >>> import qualified Data.ByteString.Lazy.Char8 as LBS8
133+-- >>> import qualified Data.Map.Strict as Map