git.iko.soy/typeable/servant
on master help sign in
Add aeson and Lift BaseUrl instances
a956abdOleg Grenrus
servant-client-core/servant-client-core.cabal+7−5
compare with master
unifiedsplit
@@ -46,11 +46,12 @@ library
46 --
46 --
47 -- note: mtl lower bound is so low because of GHC-7.8
47 -- note: mtl lower bound is so low because of GHC-7.8
48 build-depends:
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
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
54
55
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 #-}
1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveGeneric #-}
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
5
6
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)
21
31
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?
30
42
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
36
48
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
49
91
50−data InvalidBaseUrlException = InvalidBaseUrlException String deriving (Show, Typeable)
92+newtype InvalidBaseUrlException = InvalidBaseUrlException String deriving (Show)
51instance Exception InvalidBaseUrlException
93instance Exception InvalidBaseUrlException
52
94
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