From a956abddebca08ef028a654a62df2dc683338e94 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Tue, 18 Sep 2018 13:46:45 +0300 Subject: [PATCH] Add aeson and Lift BaseUrl instances --- servant-client-core/servant-client-core.cabal | 12 +-- .../Servant/Client/Core/Internal/BaseUrl.hs | 74 +++++++++++++++++-- 2 files changed, 75 insertions(+), 11 deletions(-) diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index dd46d112..32f37885 100644 --- a/servant-client-core/servant-client-core.cabal +++ b/servant-client-core/servant-client-core.cabal @@ -46,11 +46,12 @@ library -- -- note: mtl lower bound is so low because of GHC-7.8 build-depends: - base >= 4.7 && < 4.12 - , bytestring >= 0.10.4.0 && < 0.11 - , containers >= 0.5.5.1 && < 0.6 + base >= 4.9 && < 4.12 + , bytestring >= 0.10.8.1 && < 0.11 + , containers >= 0.5.7.1 && < 0.6 , text >= 1.2.3.0 && < 1.3 - , transformers >= 0.3.0.0 && < 0.6 + , transformers >= 0.5.2.0 && < 0.6 + , template-haskell >= 2.11.1.0 && < 2.14 -- Servant dependencies build-depends: @@ -59,7 +60,8 @@ library -- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Here can be exceptions if we really need features from the newer versions. build-depends: - base-compat >= 0.10.1 && < 0.11 + aeson >= 1.4.0.0 && < 1.5 + , base-compat >= 0.10.1 && < 0.11 , base64-bytestring >= 1.0.0.1 && < 1.1 , exceptions >= 0.10.0 && < 0.11 , free >= 5.0.2 && < 5.2 diff --git a/servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs b/servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs index c6cf55b8..585ff733 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs @@ -1,14 +1,24 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} {-# LANGUAGE ViewPatterns #-} module Servant.Client.Core.Internal.BaseUrl where 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 Data.Typeable +import qualified Data.Text as T import GHC.Generics -import Network.URI hiding +import Language.Haskell.TH.Syntax + (Lift) +import Network.URI hiding (path) import Safe import Text.Read @@ -17,16 +27,18 @@ import Text.Read data Scheme = Http -- ^ http:// | Https -- ^ https:// - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic, Lift, Data) -- | Simple data type to represent the target of HTTP requests -- for servant's automatically-generated clients. data BaseUrl = BaseUrl - { baseUrlScheme :: Scheme -- ^ URI scheme to use + { baseUrlScheme :: Scheme -- ^ URI scheme to use , baseUrlHost :: String -- ^ host (eg "haskell.org") , baseUrlPort :: Int -- ^ port (eg 80) , baseUrlPath :: String -- ^ path (eg "/a/b/c") - } deriving (Show, Ord, Generic) + } deriving (Show, Ord, Generic, Lift, Data) +-- TODO: Ord is more precise than Eq +-- TODO: Add Hashable instance? instance Eq BaseUrl where BaseUrl a b c path == BaseUrl a' b' c' path' @@ -34,6 +46,36 @@ instance Eq BaseUrl where where s ('/':x) = x s x = x +-- | >>> traverse_ (LBS8.putStrLn . encode) $ parseBaseUrl "api.example.com" +-- "http://api.example.com" +instance ToJSON BaseUrl where + toJSON = toJSON . showBaseUrl + toEncoding = toEncoding . 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 = withText "BaseUrl" $ \t -> case parseBaseUrl (T.unpack t) of + Just u -> return u + Nothing -> fail $ "Invalid base url: " ++ T.unpack t + +-- | >>> :{ +-- traverse_ (LBS8.putStrLn . encode) $ do +-- u1 <- parseBaseUrl "api.example.com" +-- u2 <- parseBaseUrl "example.com" +-- return $ Map.fromList [(u1, 'x'), (u2, 'y')] +-- :} +-- {"http://api.example.com":"x","http://example.com":"y"} +instance ToJSONKey BaseUrl where + toJSONKey = contramapToJSONKeyFunction showBaseUrl toJSONKey + +instance FromJSONKey BaseUrl where + fromJSONKey = FromJSONKeyTextParser $ \t -> case parseBaseUrl (T.unpack t) of + Just u -> return u + Nothing -> fail $ "Invalid base url: " ++ T.unpack t + +-- | >>> showBaseUrl <$> parseBaseUrl "api.example.com" +-- "http://api.example.com" showBaseUrl :: BaseUrl -> String showBaseUrl (BaseUrl urlscheme host port path) = schemeString ++ "//" ++ host ++ (portString path) @@ -47,9 +89,22 @@ showBaseUrl (BaseUrl urlscheme host port path) = (Https, 443) -> "" _ -> ":" ++ show port -data InvalidBaseUrlException = InvalidBaseUrlException String deriving (Show, Typeable) +newtype InvalidBaseUrlException = InvalidBaseUrlException String deriving (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 s = case parseURI (removeTrailingSlash s) of -- This is a rather hacky implementation and should be replaced with something @@ -69,3 +124,10 @@ parseBaseUrl s = case parseURI (removeTrailingSlash s) of removeTrailingSlash str = case lastMay str of Just '/' -> init str _ -> str + +-- $setup +-- +-- >>> import Data.Aeson +-- >>> import Data.Foldable (traverse_) +-- >>> import qualified Data.ByteString.Lazy.Char8 as LBS8 +-- >>> import qualified Data.Map.Strict as Map