git.iko.soy/servant
on master help sign in
revamp a lot of the HasClient code to thread a Req object around instead of just the path. allows for a cleaner way to handle path, query string and request body modification. add support for GET params too
50f5c36Alp Mestanogullari
servant.cabal+1
compare with master
unifiedsplit
@@ -21,6 +21,7 @@ library
21 , either
21 , either
22 , aeson
22 , aeson
23 , bytestring
23 , bytestring
24+ , exceptions
24 , string-conversions
25 , string-conversions
25 , http-client
26 , http-client
26 , http-types
27 , http-types
src/Servant.hs+85−40
@@ -18,6 +18,7 @@ import Data.Aeson
18import Data.ByteString.Lazy (ByteString)
18import Data.ByteString.Lazy (ByteString)
19import Data.Monoid
19import Data.Monoid
20import Data.Proxy
20import Data.Proxy
21+import Data.String.Conversions
21import Data.Text
22import Data.Text
22import GHC.Generics
23import GHC.Generics
23import GHC.TypeLits
24import GHC.TypeLits
@@ -29,23 +30,32 @@ import Soenke
29
30
30import qualified Network.HTTP.Client as Http.Client
31import qualified Network.HTTP.Client as Http.Client
31
32
32−-- * Captures
33−data Capture sym a
34−
35class FromText a where
33class FromText a where
36− capture :: Text -> Maybe a
34+ fromText :: Text -> Maybe a
37
35
38class ToText a where
36class ToText a where
39 toText :: a -> Text
37 toText :: a -> Text
40
38
41instance FromText Text where
39instance FromText Text where
42− capture = Just
40+ fromText = Just
43
41
44instance ToText Text where
42instance ToText Text where
45 toText = id
43 toText = id
46
44
45+instance FromText Bool where
46+ fromText "true" = Just True
47+ fromText "false" = Just False
48+ fromText _ = Nothing
49+
50+instance ToText Bool where
51+ toText True = "true"
52+ toText False = "false"
53+
54+-- * Captures
55+data Capture sym a
56+
47captured :: FromText a => proxy (Capture sym a) -> Text -> Maybe a
57captured :: FromText a => proxy (Capture sym a) -> Text -> Maybe a
48−captured _ = capture
58+captured _ = fromText
49
59
50instance (KnownSymbol capture, FromText a, HasServer sublayout)
60instance (KnownSymbol capture, FromText a, HasServer sublayout)
51 => HasServer (Capture capture a :> sublayout) where
61 => HasServer (Capture capture a :> sublayout) where
@@ -70,9 +80,11 @@ instance (KnownSymbol capture, ToText a, HasClient sublayout)
70 type Client (Capture capture a :> sublayout) =
80 type Client (Capture capture a :> sublayout) =
71 a -> Client sublayout
81 a -> Client sublayout
72
82
73− clientWithRoute Proxy path val =
83+ clientWithRoute Proxy req val =
74− clientWithRoute (Proxy :: Proxy sublayout)
84+ clientWithRoute (Proxy :: Proxy sublayout) $
85+ appendToPath p req
86+
75− (path ++ "/" ++ unpack (toText val))
87+ where p = unpack (toText val)
76
88
77-- * Request Body support
89-- * Request Body support
78data RQBody a
90data RQBody a
@@ -89,39 +101,54 @@ instance (FromJSON a, HasServer sublayout)
89 Nothing -> return Nothing
101 Nothing -> return Nothing
90 Just v -> route (Proxy :: Proxy sublayout) (subserver v) request
102 Just v -> route (Proxy :: Proxy sublayout) (subserver v) request
91
103
92−instance (ToJSON a, FromJSON b)
104+instance (ToJSON a, HasClient sublayout)
93− => HasClient (RQBody a :> Post b) where
105+ => HasClient (RQBody a :> sublayout) where
94
106
95− type Client (RQBody a :> Post b) =
107+ type Client (RQBody a :> sublayout) =
96− a -> URI -> EitherT String IO b
108+ a -> Client sublayout
97
109
98− clientWithRoute Proxy path body uri = do
110+ clientWithRoute Proxy req body =
99− partialRequest <- liftIO . Http.Client.parseUrl $
111+ clientWithRoute (Proxy :: Proxy sublayout) $
100− show ( nullURI { uriPath = path }
112+ setRQBody (encode body) req
101− `relativeTo` uri
102− )
103
113
104− let request = partialRequest
114+-- * GET params support (i.e query string arguments)
105− { Http.Client.method = methodPost
115+data GetParam sym a
106− , Http.Client.requestBody = Http.Client.RequestBodyLBS (encode body)
107− }
108
116
109− innerResponse <- liftIO . __withGlobalManager $ \ manager ->
117+instance (KnownSymbol sym, FromText a, HasServer sublayout)
110− Http.Client.httpLbs request manager
118+ => HasServer (GetParam sym a :> sublayout) where
111
119
112− when (Http.Client.responseStatus innerResponse /= status201) $
120+ type Server (GetParam sym a :> sublayout) =
113− left ("HTTP POST request failed with status: " ++ show (Http.Client.responseStatus innerResponse))
121+ Maybe a -> Server sublayout
114
122
115− maybe (left "HTTP POST request returned invalid json") return $
123+ route Proxy subserver request = do
116− decode' (Http.Client.responseBody innerResponse)
124+ let querytext = parseQueryText $ rawQueryString request
125+ param =
126+ case lookup paramName querytext of
127+ Nothing -> Nothing -- param absent from the query string
128+ Just Nothing -> Nothing -- param present with no value -> Nothing
129+ Just (Just v) -> fromText v -- if present, we try to convert to
130+ -- the right type
117
131
118−-- * Example
132+ route (Proxy :: Proxy sublayout) (subserver param) request
119
133
120−type TestApi = "hello" :> Capture "name" Text :> Get Greet
134+ where paramName = cs $ symbolVal (Proxy :: Proxy sym)
121− :<|> "greet" :> RQBody Greet :> Post Greet
122
135
123−testApi :: Proxy TestApi
136+instance (KnownSymbol sym, ToText a, HasClient sublayout)
124−testApi = Proxy
137+ => HasClient (GetParam sym a :> sublayout) where
138+
139+ type Client (GetParam sym a :> sublayout) =
140+ Maybe a -> Client sublayout
141+
142+ -- if mparam = Nothing, we don't add it to the query string
143+ clientWithRoute Proxy req mparam =
144+ clientWithRoute (Proxy :: Proxy sublayout) $
145+ appendToQueryString pname mparamText req
146+
147+ where pname = pack pname'
148+ pname' = symbolVal (Proxy :: Proxy sym)
149+ mparamText = fmap toText mparam
150+
151+-- * Example
125
152
126data Greet = Greet { msg :: Text }
153data Greet = Greet { msg :: Text }
127 deriving (Generic, Show)
154 deriving (Generic, Show)
@@ -129,29 +156,47 @@ data Greet = Greet { msg :: Text }
129instance FromJSON Greet
156instance FromJSON Greet
130instance ToJSON Greet
157instance ToJSON Greet
131
158
159+-- API specification
160+type TestApi =
161+ "hello" :> Capture "name" Text :> GetParam "capital" Bool :> Get Greet
162+ :<|> "greet" :> RQBody Greet :> Post Greet
163+
164+testApi :: Proxy TestApi
165+testApi = Proxy
166+
167+-- Server-side handlers
132server :: Server TestApi
168server :: Server TestApi
133server = hello :<|> greet
169server = hello :<|> greet
134
170
171+ where hello name Nothing = hello name (Just False)
135− where hello = return . Greet . ("Hello, " <>)
172+ hello name (Just False) = return . Greet $ "Hello, " <> name
173+ hello name (Just True) = return . Greet . toUpper $ "Hello, " <> name
174+
136 greet = return
175 greet = return
137
176
138−getGreet :: Text -> URI -> EitherT String IO Greet
177+-- Client-side query functions
139−postGreet :: Greet -> URI -> EitherT String IO Greet
178+clientApi :: Client TestApi
179+clientApi = client testApi
140
180
181+getGreet :: Text -> Maybe Bool -> URI -> EitherT String IO Greet
182+postGreet :: Greet -> URI -> EitherT String IO Greet
141−getGreet :<|> postGreet
183+getGreet :<|> postGreet = clientApi
142− = client testApi
143
184
185+-- Turn the server into a WAI app
144test :: Application
186test :: Application
145test = serve testApi server
187test = serve testApi server
146
188
189+-- Run the server
147runTestServer :: Port -> IO ()
190runTestServer :: Port -> IO ()
148runTestServer port = run port test
191runTestServer port = run port test
149
192
193+-- Run some queries against the server
150runTest :: IO ()
194runTest :: IO ()
151runTest = do
195runTest = do
152 tid <- forkIO $ runTestServer 8001
196 tid <- forkIO $ runTestServer 8001
153− let Just uri = parseURI "http://localhost:8001/"
197+ let Just uri = parseURI "http://localhost:8001"
154− print =<< runEitherT (getGreet "alp" uri)
198+ print =<< runEitherT (getGreet "alp" (Just True) uri)
199+ print =<< runEitherT (getGreet "alp" (Just False) uri)
155 let g = Greet "yo"
200 let g = Greet "yo"
156 print =<< runEitherT (postGreet g uri)
201 print =<< runEitherT (postGreet g uri)
157 killThread tid
202 killThread tid
src/Soenke.hs+55−21
@@ -4,12 +4,14 @@ module Soenke where
4
4
5import Control.Concurrent
5import Control.Concurrent
6import Control.Monad
6import Control.Monad
7+import Control.Monad.Catch
7import Control.Monad.IO.Class
8import Control.Monad.IO.Class
8import Control.Monad.Trans.Either
9import Control.Monad.Trans.Either
9import Data.Aeson
10import Data.Aeson
10import Data.ByteString.Lazy (ByteString)
11import Data.ByteString.Lazy (ByteString)
11import Data.Proxy
12import Data.Proxy
12import Data.String.Conversions
13import Data.String.Conversions
14+import Data.Text (Text)
13import GHC.TypeLits
15import GHC.TypeLits
14import Network.HTTP.Client (Manager, defaultManagerSettings,
16import Network.HTTP.Client (Manager, defaultManagerSettings,
15 newManager)
17 newManager)
@@ -116,11 +118,45 @@ instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
116
118
117-- | 'client' allows you to produce operations to query an API from a client.
119-- | 'client' allows you to produce operations to query an API from a client.
118client :: forall layout . HasClient layout => Proxy layout -> Client layout
120client :: forall layout . HasClient layout => Proxy layout -> Client layout
119−client Proxy = clientWithRoute (Proxy :: Proxy layout) ""
121+client Proxy = clientWithRoute (Proxy :: Proxy layout) defReq
120
122
121class HasClient layout where
123class HasClient layout where
122 type Client layout :: *
124 type Client layout :: *
123− clientWithRoute :: Proxy layout -> String -> Client layout
125+ clientWithRoute :: Proxy layout -> Req -> Client layout
126+
127+data Req = Req
128+ { reqPath :: String
129+ , qs :: QueryText
130+ , reqBody :: ByteString
131+ }
132+
133+defReq :: Req
134+defReq = Req "" [] ""
135+
136+appendToPath :: String -> Req -> Req
137+appendToPath p req =
138+ req { reqPath = reqPath req ++ "/" ++ p }
139+
140+appendToQueryString :: Text -- ^ param name
141+ -> Maybe Text -- ^ param value
142+ -> Req
143+ -> Req
144+appendToQueryString pname pvalue req
145+ | pvalue == Nothing = req
146+ | otherwise = req { qs = qs req ++ [(pname, pvalue)]
147+ }
148+
149+setRQBody :: ByteString -> Req -> Req
150+setRQBody b req = req { reqBody = b }
151+
152+reqToRequest :: (Functor m, MonadThrow m) => Req -> URI -> m Http.Client.Request
153+reqToRequest req uri = fmap (setrqb . setQS ) $ Http.Client.parseUrl url
154+
155+ where url = show $ nullURI { uriPath = reqPath req }
156+ `relativeTo` uri
157+
158+ setrqb r = r { Http.Client.requestBody = Http.Client.RequestBodyLBS (reqBody req) }
159+ setQS = Http.Client.setQueryString $ queryTextToQuery (qs req)
124
160
125{-# NOINLINE __manager #-}
161{-# NOINLINE __manager #-}
126__manager :: MVar Manager
162__manager :: MVar Manager
@@ -133,9 +169,9 @@ __withGlobalManager action = modifyMVar __manager $ \ manager -> do
133
169
134instance FromJSON result => HasClient (Get result) where
170instance FromJSON result => HasClient (Get result) where
135 type Client (Get result) = URI -> EitherT String IO result
171 type Client (Get result) = URI -> EitherT String IO result
136− clientWithRoute Proxy path uri = do
172+ clientWithRoute Proxy req uri = do
137− innerRequest <- liftIO $
173+ innerRequest <- liftIO $ reqToRequest req uri
138− Http.Client.parseUrl (show (nullURI{uriPath = path} `relativeTo` uri))
174+
139 innerResponse <- liftIO $ __withGlobalManager $ \ manager ->
175 innerResponse <- liftIO $ __withGlobalManager $ \ manager ->
140 Http.Client.httpLbs innerRequest manager
176 Http.Client.httpLbs innerRequest manager
141 when (Http.Client.responseStatus innerResponse /= ok200) $
177 when (Http.Client.responseStatus innerResponse /= ok200) $
@@ -144,18 +180,13 @@ instance FromJSON result => HasClient (Get result) where
144 decode' (Http.Client.responseBody innerResponse)
180 decode' (Http.Client.responseBody innerResponse)
145
181
146instance FromJSON a => HasClient (Post a) where
182instance FromJSON a => HasClient (Post a) where
147− type Client (Post a) = ByteString -> URI -> EitherT String IO a
183+ type Client (Post a) = URI -> EitherT String IO a
148
184
149− clientWithRoute Proxy path rqbody uri = do
185+ clientWithRoute Proxy req uri = do
150− partialRequest <- liftIO . Http.Client.parseUrl $
186+ partialRequest <- liftIO $ reqToRequest req uri
151− show ( nullURI { uriPath = path }
152− `relativeTo` uri
153− )
154
187
155− let request = partialRequest
156− { Http.Client.method = methodPost
188+ let request = partialRequest { Http.Client.method = methodPost
157− , Http.Client.requestBody = Http.Client.RequestBodyLBS rqbody
158− }
189+ }
159
190
160 innerResponse <- liftIO . __withGlobalManager $ \ manager ->
191 innerResponse <- liftIO . __withGlobalManager $ \ manager ->
161 Http.Client.httpLbs request manager
192 Http.Client.httpLbs request manager
@@ -168,12 +199,15 @@ instance FromJSON a => HasClient (Post a) where
168
199
169instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where
200instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where
170 type Client (path :> sublayout) = Client sublayout
201 type Client (path :> sublayout) = Client sublayout
202+
171− clientWithRoute Proxy path =
203+ clientWithRoute Proxy req =
172− clientWithRoute (Proxy :: Proxy sublayout)
204+ clientWithRoute (Proxy :: Proxy sublayout) $
205+ appendToPath p req
206+
173− (path ++ "/" ++ (symbolVal (Proxy :: Proxy path)))
207+ where p = symbolVal (Proxy :: Proxy path)
174
208
175instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
209instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
176 type Client (a :<|> b) = Client a :<|> Client b
210 type Client (a :<|> b) = Client a :<|> Client b
177− clientWithRoute Proxy path =
211+ clientWithRoute Proxy req =
178− clientWithRoute (Proxy :: Proxy a) path :<|>
212+ clientWithRoute (Proxy :: Proxy a) req :<|>
179− clientWithRoute (Proxy :: Proxy b) path
213+ clientWithRoute (Proxy :: Proxy b) req