Merge pull request #1037 from phadej/some-lift

Add aeson and Lift BaseUrl instances
This commit is contained in:
Oleg Grenrus 2018-09-18 14:35:38 +03:00 committed by GitHub
commit 2c70a2b3f5
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
2 changed files with 75 additions and 11 deletions

View file

@ -46,11 +46,12 @@ library
-- --
-- note: mtl lower bound is so low because of GHC-7.8 -- note: mtl lower bound is so low because of GHC-7.8
build-depends: build-depends:
base >= 4.7 && < 4.12 base >= 4.9 && < 4.12
, bytestring >= 0.10.4.0 && < 0.11 , bytestring >= 0.10.8.1 && < 0.11
, containers >= 0.5.5.1 && < 0.6 , containers >= 0.5.7.1 && < 0.6
, text >= 1.2.3.0 && < 1.3 , 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 -- Servant dependencies
build-depends: build-depends:
@ -59,7 +60,8 @@ library
-- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- 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. -- Here can be exceptions if we really need features from the newer versions.
build-depends: 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 , base64-bytestring >= 1.0.0.1 && < 1.1
, exceptions >= 0.10.0 && < 0.11 , exceptions >= 0.10.0 && < 0.11
, free >= 5.0.2 && < 5.2 , free >= 5.0.2 && < 5.2

View file

@ -1,13 +1,23 @@
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
module Servant.Client.Core.Internal.BaseUrl where module Servant.Client.Core.Internal.BaseUrl where
import Control.Monad.Catch import Control.Monad.Catch
(Exception, MonadThrow, throwM) (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.List
import Data.Typeable import qualified Data.Text as T
import GHC.Generics import GHC.Generics
import Language.Haskell.TH.Syntax
(Lift)
import Network.URI hiding import Network.URI hiding
(path) (path)
import Safe import Safe
@ -17,7 +27,7 @@ import Text.Read
data Scheme = data Scheme =
Http -- ^ http:// Http -- ^ http://
| Https -- ^ https:// | Https -- ^ https://
deriving (Show, Eq, Ord, Generic) deriving (Show, Eq, Ord, Generic, Lift, Data)
-- | Simple data type to represent the target of HTTP requests -- | Simple data type to represent the target of HTTP requests
-- for servant's automatically-generated clients. -- for servant's automatically-generated clients.
@ -26,7 +36,9 @@ data BaseUrl = BaseUrl
, baseUrlHost :: String -- ^ host (eg "haskell.org") , baseUrlHost :: String -- ^ host (eg "haskell.org")
, baseUrlPort :: Int -- ^ port (eg 80) , baseUrlPort :: Int -- ^ port (eg 80)
, baseUrlPath :: String -- ^ path (eg "/a/b/c") , 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 instance Eq BaseUrl where
BaseUrl a b c path == BaseUrl a' b' c' path' BaseUrl a b c path == BaseUrl a' b' c' path'
@ -34,6 +46,36 @@ instance Eq BaseUrl where
where s ('/':x) = x where s ('/':x) = x
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 -> String
showBaseUrl (BaseUrl urlscheme host port path) = showBaseUrl (BaseUrl urlscheme host port path) =
schemeString ++ "//" ++ host ++ (portString </> path) schemeString ++ "//" ++ host ++ (portString </> path)
@ -47,9 +89,22 @@ showBaseUrl (BaseUrl urlscheme host port path) =
(Https, 443) -> "" (Https, 443) -> ""
_ -> ":" ++ show port _ -> ":" ++ show port
data InvalidBaseUrlException = InvalidBaseUrlException String deriving (Show, Typeable) newtype InvalidBaseUrlException = InvalidBaseUrlException String deriving (Show)
instance Exception InvalidBaseUrlException 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 :: MonadThrow m => String -> m BaseUrl
parseBaseUrl s = case parseURI (removeTrailingSlash s) of parseBaseUrl s = case parseURI (removeTrailingSlash s) of
-- This is a rather hacky implementation and should be replaced with something -- 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 removeTrailingSlash str = case lastMay str of
Just '/' -> init str Just '/' -> init str
_ -> 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