Merge pull request #1037 from phadej/some-lift
Add aeson and Lift BaseUrl instances
This commit is contained in:
commit
2c70a2b3f5
2 changed files with 75 additions and 11 deletions
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in a new issue