a956abd · servant · git.iko.soy

git.iko.soy/servant

on master help sign in

Add aeson and Lift BaseUrl instances

a956abdOleg Grenrus8 years ago

servant-client-core/servant-client-core.cabal+7−5

compare with master

unifiedsplit

@@ -46,11 +46,12 @@ library

46 --

47 -- note: mtl lower bound is so low because of GHC-7.8

48 build-depends:

49− base >= 4.7 && < 4.12

49+ base >= 4.9 && < 4.12

50− , bytestring >= 0.10.4.0 && < 0.11

50+ , bytestring >= 0.10.8.1 && < 0.11

51− , containers >= 0.5.5.1 && < 0.6

51+ , containers >= 0.5.7.1 && < 0.6

52 , text >= 1.2.3.0 && < 1.3

53− , transformers >= 0.3.0.0 && < 0.6

53+ , transformers >= 0.5.2.0 && < 0.6

54+ , template-haskell >= 2.11.1.0 && < 2.14

55 -- Servant dependencies

56 -- Servant dependencies

56 build-depends:

57 build-depends:

@@ -59,7 +60,8 @@ library

59 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.

60 -- Other dependencies: Lower bound around what is in the latest Stackage LTS.

60 -- Here can be exceptions if we really need features from the newer versions.

61 -- Here can be exceptions if we really need features from the newer versions.

61 build-depends:

62 build-depends:

63+ aeson >= 1.4.0.0 && < 1.5

62− base-compat >= 0.10.1 && < 0.11

64+ , base-compat >= 0.10.1 && < 0.11

63 , base64-bytestring >= 1.0.0.1 && < 1.1

65 , base64-bytestring >= 1.0.0.1 && < 1.1

64 , exceptions >= 0.10.0 && < 0.11

66 , exceptions >= 0.10.0 && < 0.11

65 , free >= 5.0.2 && < 5.2

67 , free >= 5.0.2 && < 5.2

servant-client-core/src/Servant/Client/Core/Internal/BaseUrl.hs+68−6

@@ -1,14 +1,24 @@

1{-# LANGUAGE DeriveDataTypeable #-}

2{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE DeriveLift #-}

3{-# LANGUAGE ViewPatterns #-}

4{-# LANGUAGE ViewPatterns #-}

4module Servant.Client.Core.Internal.BaseUrl where

5module Servant.Client.Core.Internal.BaseUrl where

6import Control.Monad.Catch

7import Control.Monad.Catch

7 (Exception, MonadThrow, throwM)

8 (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)

8import Data.List

16import Data.List

9−import Data.Typeable

17+import qualified Data.Text as T

10import GHC.Generics

18import GHC.Generics

19+import Language.Haskell.TH.Syntax

20+ (Lift)

11−import Network.URI hiding

21+import Network.URI hiding

12 (path)

22 (path)

13import Safe

23import Safe

14import Text.Read

24import Text.Read

@@ -17,16 +27,18 @@ import Text.Read

17data Scheme =

27data Scheme =

18 Http -- ^ http://

28 Http -- ^ http://

19 | Https -- ^ https://

29 | Https -- ^ https://

20− deriving (Show, Eq, Ord, Generic)

30+ deriving (Show, Eq, Ord, Generic, Lift, Data)

22-- | Simple data type to represent the target of HTTP requests

32-- | Simple data type to represent the target of HTTP requests

23-- for servant's automatically-generated clients.

33-- for servant's automatically-generated clients.

24data BaseUrl = BaseUrl

34data BaseUrl = BaseUrl

25− { baseUrlScheme :: Scheme -- ^ URI scheme to use

35+ { baseUrlScheme :: Scheme -- ^ URI scheme to use

26 , baseUrlHost :: String -- ^ host (eg "haskell.org")

36 , baseUrlHost :: String -- ^ host (eg "haskell.org")

27 , baseUrlPort :: Int -- ^ port (eg 80)

37 , baseUrlPort :: Int -- ^ port (eg 80)

28 , baseUrlPath :: String -- ^ path (eg "/a/b/c")

38 , 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?

31instance Eq BaseUrl where

43instance Eq BaseUrl where

32 BaseUrl a b c path == BaseUrl a' b' c' path'

44 BaseUrl a b c path == BaseUrl a' b' c' path'

@@ -34,6 +46,36 @@ instance Eq BaseUrl where

34 where s ('/':x) = x

46 where s ('/':x) = x

35 s x = x

47 s x = x

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"

37showBaseUrl :: BaseUrl -> String

79showBaseUrl :: BaseUrl -> String

38showBaseUrl (BaseUrl urlscheme host port path) =

80showBaseUrl (BaseUrl urlscheme host port path) =

39 schemeString ++ "//" ++ host ++ (portString </> path)

81 schemeString ++ "//" ++ host ++ (portString </> path)

@@ -47,9 +89,22 @@ showBaseUrl (BaseUrl urlscheme host port path) =

47 (Https, 443) -> ""

89 (Https, 443) -> ""

48 _ -> ":" ++ show port

90 _ -> ":" ++ show port

50−data InvalidBaseUrlException = InvalidBaseUrlException String deriving (Show, Typeable)

92+newtype InvalidBaseUrlException = InvalidBaseUrlException String deriving (Show)

51instance Exception InvalidBaseUrlException

93instance Exception InvalidBaseUrlException

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+--

53parseBaseUrl :: MonadThrow m => String -> m BaseUrl

108parseBaseUrl :: MonadThrow m => String -> m BaseUrl

54parseBaseUrl s = case parseURI (removeTrailingSlash s) of

109parseBaseUrl s = case parseURI (removeTrailingSlash s) of

55 -- This is a rather hacky implementation and should be replaced with something

110 -- This is a rather hacky implementation and should be replaced with something

@@ -69,3 +124,10 @@ parseBaseUrl s = case parseURI (removeTrailingSlash s) of

69 removeTrailingSlash str = case lastMay str of

124 removeTrailingSlash str = case lastMay str of

70 Just '/' -> init str

125 Just '/' -> init str

71 _ -> str

126 _ -> 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